DYNAC  6.0.R16
/Users/yngvelevinsen/Programming/dynac/dynac.F90
Go to the documentation of this file.
1  block data
2  implicit real *8(a-h, o-z)
3  common /consta/vl, pi, xmat, rpel, qst
4  common /gaus13/h(13), t(13)
5  common /gaus17/h1(17), t1(17)
6  common /radia/trt, rmoy, xintf, crae
7  data crae, xintf/2.81793910e-13, .86967/
8  data vl, xmat, rpel, qst/2.99792458e10, 938.27231, 28.17938e-14, 1./
9  data h/.040484004, .092121499, .138873510, .178145981, .207816048, .226283180, .232551553, .226283180, .207816048, &
10  .178145981, .138873510, .092121499, .040484004/
11  data t/ -.984183055, -.917598399, -.801578091, -.642349339, -.448492751, -.230458316, 0., .230458316, .448492751, &
12  .642349339, .801578091, .917598399, .984183055/
13  data h1/ -.990575473, -.950675522, -.880239154, -.781514004, -.657671159, -.512690537, -.351231763, -.178484181, &
14  0., .178484181, .351231763, .512690537, .657671159, .781514004, .880239154, .950675522, .990575473/
15  data t1/.024148303, .055459529, .085036148, .111883847, .135136368, .154045761, .168004102, .176562705, &
16  .179446470, .176562705, .168004102, .154045761, .135136368, .111883847, .085036148, .055459529, .024148303/
17  common /randu/ck(15), kmax
18  ! randu(j):contains the Chebitcheff coefficients Ck in table 20.
19  ! kmax is the total number of these coefficients(from 1)
20  data (ck(j), j=1, 7)/.98933556, -.68838689, .28191718, -.66389307e-01, .87406854e-02, -.59534602e-03, &
21  .16300617e-04/
22  ! xx data (ck(j),j=1,10)/.99927015,-.78398394,.44577741,
23  ! xx * -.18252873,.51928922e-01,-.99821428e-02,
24  ! xx * .1259644e-02,-.99460265e-04,.44427251e-05,
25  ! xx * -.85528336e-07/
26  ! xx data (ck(j),j=1,12)/.99989097,-.79469098,.48376369,
27  ! xx * -.23183581,.85333907e-01,-.23354050e-01,
28  ! xx * .46284273e-02,-.64840101e-03,.62211306e-04,
29  ! xx * -.38752189e-05,.14087289e-06,-.22650639e-08/
30  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
31  ! pi2=pi*pi, sqpi=(pi/2)**3/2 , pwtpi=(2*pi)**3/2 ,sqpi2=sqrt(pi/2.)
32  data kmax/7/
33  end block data
34  ! *******************************************************************
35  ! PROGRAM DYNAC
36  ! THIS SOFTWARE WAS ORIGINALLY PRODUCED BY CERN/PS, CEN/SACLAY
37 
38  ! @version 6.0R15
39  ! @date 30-Dec-2015
40 
41  ! @author P. LAPOSTOLLE CONSULTANT (Paris, France)
42  ! @author E. TANKE ESS (Lund, Sweden)
43  ! @author S. VALERO CONSULTANT (Paris, France)
44 
45  ! Modified and maintained by :
46  ! - TANKE Eugene
47  ! - VALERO Saby
48  ! *******************************************************************
49  program dynac
50  implicit real *8(a-h, o-z)
51  parameter(ncards=64, iptsz=100002, maxcell=3000, maxcell1=3000)
52  common /itvole/itvol, imamin
53  common /consta/vl, pi, xmat, rpel, qst
54  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
55  ! pi2=pi*pi, sqpi=(pi/2)**3/2 , pwtpi=(2*pi)**3/2 ,sqpi2=sqrt(pi/2.)
56  common /fene/wdisp, wphas, wx, wy, rlim, ifw
57  common /dyn/tref, vref
58  common /dyni/vrefi, trefi, fhinit, acpt
59  logical acpt
60  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
61  common /azlist/icont, iprin
62  common /carac/cara(10)
63  common /compt/nrres, nrtre, nrbunc, nrdbun
64  common /compt1/ndtl, ncavmc, ncavnm
65  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
66  common /faisc/f(10, iptsz), imax, ngood
67  common /tapes/in, ifile, meta
68  common /shif/dtiph, shift
69  common /tilt/tipha, tix, tiy, shifw, shifp
70  common /bloc21/be, apb(2), layl, layx, rabt
71  real *8 layl, layx
72  common /poro/irot1, irot2
73  logical irot1, irot2
74  common /etchas/fractx, fracty, fractl
75  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
76  common /davprt/shortl
77  common /shortl/davprt
78  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
79  common /etcha3/ichxyz(iptsz)
80  common /dcspa/iesp
81  common /tstnt/intgct
82  common /tabsch/ideg, nn, pchoix
83  common /cmpte/iell
84  common /cptemit/xltot(maxcell1), nbemit
85  common /rfield/ifield
86  common /posc/xpsc
87  common /rander/ialin
88  common /apel/iapel
89  common /qskew/qtwist, iqrand, itwist, iaqu
90  common /femt/iemgrw, iemqesg
91  common /mode/eflvl, rflvl
92  common /aerp/vphase, vfield, ierpf
93  common /blvl/bflvl
94  common /rec/irec
95  common /histo/centre(6)
96  common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
97  common /zones/frms(6), nzone
98  logical chasit, shift, itvol, imamin
99  logical ichaes, iesp, ifield, ialin, itwist, iemgrw
100  character *80 cara, cmnt, text, patitl, ofeldf, ofelds
101  character *80 davprt(maxcell1)
102  character *8 kle(ncards), kley
103  character *12 fdrft
104  character *160 titre
105  character iitime*30
106  common /cespch/nchge, ichsp, nppi
107  logical ichsp
108  common /drfq/prfq(9)
109  common /alin/xl, yl, xpl, ypl
110  common /trcmp/pchoixa
111  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
112  common /mcs/imcs, ncstat, cstat(20)
113  common /secdr/iseor
114  logical iseor
115  common /rayshy/iraysh
116  common /trfq/icour, ncell
117  common /newref/dephas, dewref, iref, irefw
118  common /tofev/ttvols
119  common /conti/irfqp
120  logical irfqp
121  common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
122  common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
123  common /grot/rzot, izrot
124  ! allow plotting the beam after sector nsprint ******
125  common /isector/nsector, nsprint
126  common /mingw/mg
127  common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
128  common /fcont/ifcont
129  logical ifcont, mg, ffound
130  ! ********************************************
131  ! reservation for TRACE3D related stuff
132  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
133  common /t3dfld/fldctr(15), zend(15), t3d
134  logical t3d, xiset
135  character *128 trace3h, trace3t, tif, tifa, tifb
136  ! ********************************************
137  common /elq/inisk
138  integer inisk
139  logical izrot
140  logical iraysh, cfound
141  data kle/'GEBEAM', 'INPUT', 'RDBEAM', 'ETAC', 'DRIFT', 'QUADRUPO', 'SEXTUPO', 'QUADSXT', 'SOLENO', 'SOQUAD', &
142  'BMAGNET', 'CAVMC', 'CAVSC', 'FIELD', 'HARM', 'BUNCHER', 'RFQCL', 'NEWF', 'NREF', 'SCDYNAC', 'SCDYNEL', 'SCPOS', &
143  'TILT', 'TILZ', 'CHANGREF', 'TOF', 'REJECT', 'ZROT', 'ALINER', 'ACCEPT', 'EMIT', 'EMITGR', 'COMMENT', 'WRBEAM', &
144  'ENVEL', 'CHASE', 'RWFIELD', 'RANDALI', 'TWQA', 'EMIPRT', 'MMODE', 'RFQPTQ', 'STRIPPER', 'STEER', 'ZONES', &
145  'PROFGR', 'SECORD', 'RASYN', 'FDRIFT', 'FSOLE', 'EGUN', 'COMPRES', 'STOP', 'REFCOG', 'FPART', 'QUAELEC', &
146  'QUAFK', 'CAVNUM', 'EDFLEC', 'EMITL', 'RFKICK', 'FIRORD', 'DCBEAM', 'T3D'/
147  integer narg, i
148  character *80 inarg, myarg(10), myfile, wfile, infiln, shortl
149  character *10 plane
150  logical g77, gfortran
151  ! if mg=.true., use MINGW on windows, which has a different result for
152  ! ctime function than standard gfortran
153  ! default is mg=.false. This can be set by giving mingw as argument on
154  ! the command line
155  mg = .false.
156  ! get arguments from the command line
157  ! format for dynac:
158  ! dynac file1 [-h]
159  ! where: -file1 is the input file, describing the beamline
160  ! -h print help info
161  gfortran = .true.
162  ! g77 in case of g77, set g77=.true. ; in case of gfortran,
163  ! set g77=.false.
164  g77 = .false.
165  if (g77) gfortran = .false.
166  narg = 0
167  if (gfortran) then
168  do
169  call get_command_argument(narg, inarg)
170  if (len_trim(inarg)==0) exit
171  narg = narg + 1
172  ! g77 in case of g77, comment out the next line; in case of
173  ! gfortran, leave it in
174  myarg(narg) = trim(inarg)
175  end do
176  else
177  write (6, *) 'Compatible with g77'
178  end if
179  ! INPUT ARGUMENTS:
180  ! *******************************************************************
181  if (gfortran) then
182  ffound = .false.
183  do i = 2, narg
184  text = myarg(i)
185  if (text(1:1)/='-') then
186  ! the input argument is the name of the input file
187  write (6, 2917) myarg(i)
188 2917 format ('Input file: ', a)
189  infiln = myarg(i)
190  ! 7 or 'in' is the unit corresponding to the dynac input file
191  ! describing the accelerator or transport line
192  open (7, file=myarg(i), status='unknown')
193  ffound = .true.
194  else
195 #ifdef MINGW
196  ! if mg=.true., use MINGW on windows, which has a different result
197  ! for ctime function than standard gfortran
198  mg = .true.
199  write (6, *) 'Using MINGW gfortran format on MSWindows'
200 #endif
201  if (myarg(i)=='-h') then
202  ! print out of help message, starting with DYNAC version
203  write (6, 3101)
204  write (6, *) 'Command format:'
205  write (6, *) 'dynacv6_0 [-h] [-mingw] [file1]'
206  write (6, *) 'where file1 is the input file, describing ', 'the beamline'
207  write (6, *) 'Optional arguments:'
208  write (6, *) '-h will list the argument options (this ', 'list)'
209  stop
210  end if
211  end if
212  end do
213  if (.not. ffound) then
214  write (6, *) 'Error: Input file name required'
215  write (6, *) 'Type'
216  write (6, *) 'dynacv6_0 -h'
217  write (6, *) 'for syntax'
218  stop
219  end if
220  end if
221  ! *******************************************************************
222  ! OUTPUT FILES:
223 
224  ! 'dynac.long' : print extensive computations information
225 
226  ! 'dynac.short' : print essentials of beam dynamics information
227 
228  ! 'dynac.print' : printout of the envelope and the emittance of the
229  ! beam in the directions x, y and z at each position
230  ! of the optical and accelerating elements, as well as
231  ! the number of good particles
232 
233  ! 'dynac.dmp' : printout of cavity cell related data:
234  ! cell number,synchronous phase (deg),relativistic
235  ! beta (output), output energy (MeV),
236  ! hor. emittance (mm.mrad, normalized),
237  ! ver. emittance (mm.mrad, normalized),
238  ! longitudinal emittance (ns.kev)
239 
240  ! 'beam_core.dst': print the coordinates of the particles kept by
241  ! CHASE
242 
243  ! 'beam_remove.dst': print the coordinates of the particles
244  ! removed by CHASE
245 
246  ! 'dynac_in_pr.dst': print of the coordinates of the particles at the
247  ! input of the machine
248 
249  ! 'emit.plot' : datafile used for the plots
250 
251  ! *************************************************************************************************
252  open (16, file='dynac.long', status='unknown')
253  open (12, file='dynac.short', status='unknown')
254  open (71, file='dynac.print', status='unknown')
255  open (50, file='dynac.dmp', status='unknown')
256  open (61, file='beam_core.dst', status='unknown')
257  open (60, file='beam_remove.dst', status='unknown')
258  open (11, file='dynac_in_pr.dst', status='unknown')
259  open (66, file='emit.plot', status='unknown')
260  ! ****************************************************************************************************
261  ! *******files deactivated in the code
262 
263  ! 'emlg.data': print at each position of space charge computation:
264  ! the length(m), the longitudinal emittance growth (ns.keV),
265  ! the kinetic energy (MeV), the number of good particles
266 
267  ! 'emtr.data': print at each position of space charge computation:
268  ! the length(m), the hor. and ver. normalized emittances (mm.mrad)
269 
270  ! 'chemlg.data': as 'emlg.data' but with CHASE
271 
272  ! 'chemtr.data': as 'emtr.data' but with CHASE
273 
274  ! 'ntxyz.data' : print at each position of space charge computation:
275  ! the coordinates of the particles in the 3D plane (x(cm), y(cm) and z(cm))
276  ! This file is rewound each time, only the last result is kept
277 
278  ! 'rms.size' :print at each position of space charge computation the RMS(m) of the bunch
279  ! in x, y and z-direction
280 
281  ! 'egun_prtcl.data' : print of the coordinates of the particle icont (see RDBEAM) along the DC EGUN
282 
283  ! 'champ_sol.data' : plot field in the solenoid
284  ! ****************************************************************************************
285  ! SV 24/08/2015
286  open (13, file='emlg.data', status='unknown')
287  ! old open(14,file='emtr.data',status='unknown')
288  ! omment open(15,file='chemlg.data',status='unknown')
289  ! omment open(17,file='rms.size',status='unknown')
290  ! omment open(18,file='chemtr.data',status='unknown')
291  ! omment open(19,file='nxyz.data',status='unknown')
292  ! omment open(21,file='ntxyz.data',status='unknown')
293  ! omment open(49,file='egun_prtcl.data',status='unknown')
294  ! ****************************************************
295  ! omment write(14,7787)
296  ! omment write(18,7787)
297  ! omment7787 format(4x,'N',6x,'length',5x,'emitx',5x,'emity')
298  ! omment write(13,7788)
299  ! omment write(15,7788)
300  ! omment7788 format(4x,'N',6x,'length',5x,'emitz',6x,'energy',1x,'part.good')
301  ! ********************************************************
302  ! SV 24/10/2015
303  ! c write(13,99)
304  ! c99 format(3x,'ncav',2x,'ncell',2x,'pos I(cm)',4x,'pos S(cm)',6x,
305  ! c *'L cell(cm)',5x,'W(Mev)',7x,'dw(Mev)',6x,'TOF(dg)',7x,'Ph RF(dg)'
306  ! c *,6x,'pos M(cm)',5x,'WM(Mev)',7x,'dwM(Mev)',6x,
307  ! c *'TOFM(dg)',5x,'PhM RF(dg)')
308  ! **************************************************************************************
309  ! initialize constants
310  ! in corresponds to dynac input file
311  in = 7
312  ! itout corresponds to TRACE3D input file
313  itout = 48
314 
315  ! pi2=pi*pi, sqpi=(pi/2)**3/2 , pwtpi=(2*pi)**3/2 ,sqpi2=sqrt(pi/2.)
316  pi = 4.*atan(1.)
317  pi2 = pi*pi
318  sqpi = (pi/2)**3/2
319  pwtpi = (2*pi)**3/2
320  sqpi2 = sqrt(pi/2.)
321  ! initialize the number of charge states to 1
322  ncstat = 1
323  ! initialize the # of zones (see ZONES card) to zero
324  izrot = .false.
325  ofeldf = ' '
326  ofelds = ' '
327  icour = 0
328  ! initialize trace3d related stuff
329  ! frequency indicator
330  fid = 1.
331  t3d = .false.
332  xiset = .false.
333  kt3h = 1
334  trace3h(kt3h) = ' $DATA'
335  kt3t = 0
336  ! DONE:
337  ! DATA KLE/'GEBEAM','INPUT','RDBEAM','ETAC','DRIFT',
338  ! 1* 'QUADRUPO', , ,'SOLENO', ,
339  ! 2* 'BMAGNET', ,'CAVSC' ,'FIELD' , ,
340  ! 3* 'BUNCHER', ,'NEWF' , ,'SCDYNAC',
341  ! 11* ,'CAVNUM', , ,
342  ! TO LOOK AT:
343  ! DATA KLE/ , ,
344  ! 1* ,'SEXTUPO','QUADSXT', ,'SOQUAD',
345  ! 2* , , , , 'HARM' ,
346  ! 3* ,'RFQCL', ,'NREF', ,
347  ! 4* 'SCDYNEL','SCPOS','TILT','TILZ','CHANGREF',
348  ! 5* 'TOF','REJECT','ZROT','ALINER',
349  ! 7* 'RWFIELD','RANDALI','TWQA','EMIPRT',
350  ! 8* 'MMODE','RFQPTQ', ,'STEER',
351  ! 9* , , ,'FDRIFT','FSOLE',
352  ! 10* 'REFCOG','FPART', ,
353  ! 11* 'QUAFK', , , ,'RFKICK'
354 
355  ! IGNORE: 'ZONES','STOP','T3D','DCBEAM','FIRORD','COMMENT'
356  ! 'EMIT','EMITGR','WRBEAM','ENVEL','REJECT','CHASE'
357  ! 'ACCEPT','EMITL','EGUN','COMPRES','RASYN','SECORD'
358  ! 'STRIPPER','EDFLEC','PROFGR','QUAELEC','CAVMC'
359  acpt = .false.
360  irfqp = .false.
361  inisk = 0
362  ttvols = 0.
363  iprf = 1
364  ncell = 0
365  nzone = 0
366  eflvl = 0.
367  rflvl = 0.
368  bflvl = 0.
369  nbemit = 0
370  iell = 0
371  imcs = 0
372  ifw = 1
373  wdisp = 1000.
374  wphas = 400.*pi
375  wx = 100.
376  wy = 100.
377  rlim = 140.
378  nrtre = 0
379  do i = 1, 6
380  centre(i) = 0.
381  end do
382  do i = 1, maxcell1
383  davprt(i) = ''
384  end do
385  do i = 1, iptsz
386  ichas(i) = 1
387  ichxyz(i) = 1
388  end do
389  shift = .false.
390  ichaes = .false.
391  iseor = .false.
392  iraysh = .false.
393  icont = iptsz + 5
394  iprin = 1
395  nrres = 0
396  ndtl = 0
397  ncavnm = 0
398  ncavmc = 0
399  nrbunc = 0
400  dtiph = 0.
401  icont = 150000
402  intgct = 0
403  itye = 1000
404  ierpf = 0
405  ialin = .false.
406  itwist = .false.
407  ichsp = .false.
408  iesp = .false.
409  itvol = .false.
410  imamin = .false.
411  chasit = .false.
412  ifield = .false.
413  iemgrw = .false.
414  idav = 0
415  davtot = 0.
416  iapel = 1
417  iaqu = 1
418  xpsc = .5
419  fractx = 1.
420  fracty = 1.
421  fractl = 1.
422  iscsp = 0
423  ifile = 11
424  imax = 0
425  ! default for beams is to be bunched (not continuous)
426  ifcont = .false.
427  ! *******************************************************
428  write (6, 3101)
429  write (16, 3101)
430  write (12, 3101)
431 3101 format ('****** DYNAC V6.0R15 (Beta test), 30-Dec-2015 *******')
432  if (gfortran) then
433  write (16, *) 'Input file: ', infiln
434  write (12, *) 'Input file: ', infiln
435  end if
436  text = ' '
437  call mytime(iitime)
438  if (mg) then
439  ! using MINGW style gfortran format: 03/30/10 20:51:06 (10 is 2010)
440  text(1:4) = ' '
441  if (iitime(1:2)=='01') text(5:7) = 'Jan'
442  if (iitime(1:2)=='02') text(5:7) = 'Feb'
443  if (iitime(1:2)=='03') text(5:7) = 'Mar'
444  if (iitime(1:2)=='04') text(5:7) = 'Apr'
445  if (iitime(1:2)=='05') text(5:7) = 'May'
446  if (iitime(1:2)=='06') text(5:7) = 'Jun'
447  if (iitime(1:2)=='07') text(5:7) = 'Jul'
448  if (iitime(1:2)=='08') text(5:7) = 'Aug'
449  if (iitime(1:2)=='09') text(5:7) = 'Sep'
450  if (iitime(1:2)=='10') text(5:7) = 'Oct'
451  if (iitime(1:2)=='11') text(5:7) = 'Nov'
452  if (iitime(1:2)=='12') text(5:7) = 'Dec'
453  text(8:8) = ' '
454  text(9:10) = iitime(4:5)
455  text(11:13) = ' 20'
456  text(14:15) = iitime(7:8)
457  text(16:19) = ' at '
458  text(20:27) = iitime(10:17)
459  else
460  ! standard gfortran format: Tue Mar 30 20:51:06 2010
461  text(1:11) = iitime(1:11)
462  text(12:15) = iitime(21:24)
463  text(16:19) = ' at '
464  text(20:27) = iitime(12:19)
465  end if
466  write (6, 789) text(1:27)
467 789 format ('Started on ', a27)
468  write (16, *) 'Started on ', text(1:27)
469  write (12, *) 'Started on ', text(1:27)
470  call cpu_time(exstrt)
471  ! Read title
472  read (in, 3333) titre(1:80)
473  write (16, 3334) titre(1:80)
474  write (12, 3334) titre(1:80)
475 3333 format (a80)
476 3334 format (1x, a80)
477  ! Read the input file and check for valid cards
478  do
479  cfound = .false.
480  read (in, 3333) cmnt(1:80)
481  if (cmnt(1:1)==';') then
482  write (16, 3334) cmnt(1:80)
483  cycle
484  else
485  kley = cmnt(1:8)
486  end if
487  do i = 1, ncards
488  if (kley==kle(i)) then
489  cfound = .true.
490  exit
491  end if
492  end do
493  if (cfound) then
494  ! *********************************************************************
495  ! GEBEAM 1 | INPUT 2 | RDBEAM 3 | ETAC 4 | DRIFT 5
496  ! QUADRUPO 6 | SEXTUPO 7 | QUADSXT 8 | SOLENO 9 | SOQUAD 10
497  ! BMAGNET 11 | CAVMC 12 | CAVSC 13 | FIELD 14 | HARM 15
498  ! BUNCHER 16 | RFQCL 17 | NEWF 18 | NREF 19 | SCDYNAC 20
499  ! SCDYNEL 21 | SCPOS 22 | TILT 23 | TILZ 24 | CHANGREF 25
500  ! TOF 26 | REJECT 27 | ZROT 28 | ALINER 29 | ACCEPT 30
501  ! EMIT 31 | EMITGR 32 | COMMENT 33 | WRBEAM 34 | ENVEL 35
502  ! CHASE 36 | RWFIELD 37 | RANDALI 38 | TWQA 39 | EMIPRT 40
503  ! MMODE 41 | RFQPTQ 42 | STRIPPER 43 | STEER 44 | ZONES 45
504  ! PROFGR 46 | SECORD 47 | RASYN 48 | FDRIFT 49 | FSOLE 50
505  ! EGUN 51 | COMPRES 52 | STOP 53 | REFCOG 54 | FPART 55
506  ! QUAELEC 56 | QUAFK 57 | CAVNUM 58 | EDFLEC 59 | EMITL 60
507  ! RFKICK 61 | FIRORD 62 | DCBEAM 63 | T3D 64 |
508  ! *********************************************************************
509  if (i==1) then
510  ! AFTER GEBEAM:Generates randomly the input beam
511  write (16, *) ' TYPE CODE:GEBEAM********* '
512  call monte
513  write (16, *) '********************************'
514  else if (i==2) then
515  ! AFTER INPUT: define the dynamics at input
516  ! --- INPUT must be preceded by GEBEAM
517  ! --- the reference (synchronous) particle is the c.o.g of the bunch
518  ! --- ENTRY:
519  ! ---- 1) uem, atm, qst
520  ! --- uem : unit of Rest mass in MeV
521  ! Examples:
522  ! proton:938.27231 MeV
523  ! H- :939.3145 MeV
524  ! mesons:33.9093 MeV
525  ! pions :139.5685 MeV
526  ! kaons :493.667 MeV
527  ! electrons : 0.511 MeV
528  ! --- atm : Atomic number
529  ! --- qst : charge (unit of charge) of the reference
530 
531  ! ---- 2) enedep,tof
532  ! --- enedep: Kinetic energy of the reference
533  ! --- tofini: Time of flight of the reference at input (sec)
534  write (16, *) ' TYPE CODE:INPUT ********'
535  call entre
536  write (16, *) '********************************'
537  else if (i==3) then
538  ! AFTER RDBEAM: Read the input beam in the disk
539  write (16, *) 'TYPE CODE:RDBEAM **********'
540  ! --- ENTRY
541  ! ---- 1) filen : filename of file containing the particle distribution
542  ! ---- 2) iflag : flag type of distribution file
543  ! --- iflag = 0 particle coordinates x,xp,y,yp,z,zp with z in rad
544  ! --- iflag = 1 particle coordinates x,xp,y,yp,z,zp,q,m0 with z in rad
545  ! --- iflag = 2 particle coordinates x,xp,y,yp,z,zp,q with z in rad
546  ! --- iflag = 10 particle coordinates x,xp,y,yp,z,zp with z in ns
547  ! --- iflag = 11 particle coordinates x,xp,y,yp,z,zp,q,m0 with z in ns
548  ! --- iflag = 12 particle coordinates x,xp,y,yp,z,zp,q with z in ns
549  ! --- add 100 to the above iflg values to read a file that has Wref as
550  ! --- 4th parameter on line 1
551  ! ---- 3) freq, tof
552  ! --- freq: RF frquency (MHz)
553  ! --- tof: phase offset to be applied to the beam (deg)
554 
555  ! ---- 4) uem, atm, qst
556  ! like ENTRY in type code INPUT
557 
558  read (in, 3333) myfile(1:80)
559  write (16, *) 'Distribution file: ', myfile(1:80)
560  open (55, file=myfile, status='unknown')
561  call adjrfq
562  write (16, *) '********************************'
563  else if (i==4) then
564  ! AFTER ETAC :possibility of a multiple charge state beam
565  write (16, *) 'TYPE CODE:ETAC **********'
566  kt3h = kt3h + 1
567  trace3h(kt3h) = 'ERROR: ETAC not supported'
568  call etac
569  write (16, *) '********************************'
570  ! AFTER DRIFT : dl:drift length (cm),if dl is negatif no space charge effect
571  else if (i==5) then
572  write (16, *) 'TYPE CODE:DRIFT **********'
573  read (in, *) dl
574  kt3t = kt3t + 1
575  write (tif, 6001) kt3t, kt3t, 10.*dl
576 6001 format (' nt(', i4, ')= 1, a(1,', i4, ')=', f12.6)
577  trace3t(kt3t) = tif
578  call drift(dl)
579  write (16, *) '********************************'
580  else if (i==6) then
581  ! AFTER QUADRUPO: quadrupole
582  ! BQUAD: field at pole tip (kG)
583  ! XLQUA: EFFECTIVE LENGHT (cm )
584  ! RG: APERTURE RADIUS (cm)
585  write (16, *) 'TYPE CODE:QUADRUPO**********'
586  read (in, *) xlqua, bquad, rg
587  kt3t = kt3t + 1
588  write (tif, 6002) kt3t, kt3t, 10.*bquad/rg, xlqua*10.
589 6002 format (' nt(', i4, ')= 3, a(1,', i4, ')= ', f9.5, ' , ', f9.5)
590  trace3t(kt3t) = tif
591  call qalva(bquad, xlqua, rg)
592  write (16, *) '********************************'
593  else if (i==7) then
594  ! AFTER SEXTUPO: sextupole
595  ! IMK2: IFLAG (see arg)
596  ! ARG = KS2 (cm-3) if IMK2 = 0, otherwise ARG = BSEX (kG)
597  ! XLSEX : EFFECTIVE LENGHT (CM )
598  ! RG :APERTURE RADIUS (CM)
599  write (16, *) 'TYPE CODE:SEXTUPO**********'
600  read (in, *) imk2, arg, xlsex, rg
601  call sextu(imk2, arg, xlsex, rg)
602  write (16, *) '********************************'
603  else if (i==8) then
604  ! AFTER QUADSXT:
605  ! quadrupole associated with sextupole
606  ! IKSQ: IFLAG (see ARGS and ARGQ)
607  ! ARGS: strength of SEXTUPOLE
608  ! IKSQ = 0, then ARGS = KS2 (cm-3), otherwise ARGS = FIELD BS(kG)
609  ! ARGQ: strength of QUADRUPOLE
610  ! If IKSQ = 0, then ARGQ = K2 (cm-2), otherwise ARGQ = FIELD BQ(kG)
611  ! XLQUA : EFFECTIVE LENGHT OF THE LENS(cm)
612  ! RG : APERTURE RADIUS OF THE LENS (cm)
613  write (16, *) 'TYPE CODE:QUADSXT**********'
614  read (in, *) iksq, args, argq, xlqua, rg
615  call qasex(iksq, args, argq, xlqua, rg)
616  write (16, *) '********************************'
617  else if (i==9) then
618  ! AFTER SOLENO: solenoid
619  ! IMKS: IFLAG (see ARG)
620  ! ARG: IMKS = 0 then ARG is the strength K (cm-1), otherwise ARG is the field B (kG)
621  ! XLSOL : EFFECTIVE LENGHT (CM )
622  write (16, *) 'TYPE CODE SOLENO**********'
623  read (in, *) imks, xlsol, arg
624  call solnoid(imks, arg, xlsol)
625  write (16, *) '********************************'
626  else if (i==10) then
627  ! AFTER SOQUAD: solenoid associated with quadrupole
628  ! --IKSQ: IFLAG
629  ! --ARGS: STRENGTH or FIELD OF SOLENOID
630  ! If IKSQ = 0 then ARGS = K (cm-1), otherwise ARGS = B(kG)
631  ! --ARGQ: STRENGTH or FIELD of QUADRUPOLE
632  ! If IKSQ = 0 then ARGQ = K2 (cm-2), otherwise ARGQ = B(kG)
633  ! SIGN CONVENTIONS:
634  ! SOLENOID: K positive => rotate the transverse coordinates about the
635  ! z-axis in the clockwise direction.
636  ! QUADRUPOLE: K2 positive => focusing in the H plane (x,z)
637  ! --XLSOL : EFFECTIVE LENGHT OF THE LENS(cm)
638  ! --RG : APERTURE RADIUS OF THE LENS (cm)
639  write (16, *) 'TYPE CODE:SOQUAD**********'
640  read (in, *) iksq, args, argq, xlsol, rg
641  call solquad(iksq, args, argq, xlsol, rg)
642  write (16, *) '********************************'
643  else if (i==11) then
644  ! AFTER BMAGNET (sign conventions as in the code TRANSPORT)
645  ! NSECTOR: number of sectors dividing the bending magnet
646  ! WEDGE BENDING MAGNET
647  ! ANGL : DEG bend angle of the central trajectory
648  ! RMO : CM radius of curvature of the central trajectory
649  ! BAIM : KG field of the bending magnet
650  ! BAIM = 0 the field is computed from the momentum of the reference
651  ! otherwise the momentum is computed from the field
652  ! XN : FIELD GRADIENT (dimensionless,TRANSPORT: n)
653  ! XB : NORMALIZED SECOND DERIVATIVE OF B (TRANSPORT : beta)
654  ! AP(1) = AP(2) CM vertical half aperture (only if IPOLE = 0)
655  ! ENTRANCE FACE
656  ! PENT1 EK1 EK2 RAB1
657  ! PENT1: DEG angle of pole face rotation (deg)
658  ! RAB1 : CM radius of curvature
659  ! EK1 : integral related to the extent of the fringing field (TRANSPORT K1)
660  ! EK2 : integral related to the extent of the fringing field (TRANSPORT K2)
661  ! AP(1) : CM vertical half aperture
662  ! EXIT FACE
663  ! PENT2 SK1 SK2 RAB2
664  ! PENT2: DEG angle of pole face rotation
665  ! RAB2 : CM radius of curvature
666  ! SK1 : integral related to the extent of the fringing field
667  ! SK2 : integral related to the extent of the fringing field
668  ! AP(2) : CM vertical half aperture
669 
670  ! SPACE CHARGE COMPUTATION is automatically provided in the routine
671  ! CAUTION: with several states charges in the beam, ONLY THE SCHEFF METHOD MUST BE USED in the bending
672  ! magnet
673  ! ----------------------------------------------------------------------------------------------------------
674  !----
675  ! nsprint: allow plotting the beam after the sector number nsprint in file 13 ('emlg.data')
676  ! cc read(in,*) nsector,nsprint
677  read (in, *) nsector
678  read (in, *) angl, rmo, baim, xn, xb
679  read (in, *) pent1, rab1, ek1, ek2, apb(1)
680  ! if apb(1) ne 0 and if ek1 = 0 the program inserts a default value of ek1 = 0.5
681  if (apb(1)/=0. .and. ek1<0.) ek1 = 0.5
682  read (in, *) pent2, rab2, sk1, sk2, apb(2)
683  ! if apb(2) ne 0 and sk1 = 0 the program inserts a default value of sk1 = 0.5
684  if (apb(2)/=0. .and. sk1<0.) sk1 = 0.5
685  ! trace3d
686  ! edge
687  kt3t = kt3t + 1
688  write (tif, 6005) kt3t, kt3t, pent1, 10.*abs(rmo), 20.*apb(1), ek1, ek2
689 6005 format (' nt(', i4, ')= 9, a(1,', i4, ')=', f9.5, ' , ', f9.2, ' , ', f9.2, ' , ', f9.2, ' , ', f9.2)
690  trace3t(kt3t) = tif
691  ! bend
692  kt3t = kt3t + 1
693  write (tif, 6006) kt3t, kt3t, angl, 10.*abs(rmo)
694 6006 format (' nt(', i4, ')= 8, a(1,', i4, ')=', f9.5, ' , ', f9.2, ' , 0 , 0 ')
695  trace3t(kt3t) = tif
696  ! edge
697  kt3t = kt3t + 1
698  write (tif, 6005) kt3t, kt3t, pent2, 10.*abs(rmo), 20.*apb(2), sk1, sk2
699  trace3t(kt3t) = tif
700 
701 
702  call aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
703  write (16, *) '********************************'
704  else if (i==12) then
705  ! AFTER CAVMC: Multicell accelerating element
706  ! the electromagnetic field can be read:
707  ! in the file 'field.txt' in the form (z,E(z))
708  ! or from the type code: HARM in the form of a Fourier series expansion
709  write (16, *) 'TYPE CODE:CAVMC **********'
710  call restay
711  write (16, *) '********************************'
712  else if (i==13) then
713  ! AFTER CAVSC: single cell accelerating element
714  ! The transit time factors describe the eletromagnetic field
715  write (16, *) 'TYPE CODE:CAVSC **********'
716  call etgap
717  write (16, *) '********************************'
718  else if (i==14) then
719  ! AFTER FIELD
720  ! --- the axial field of the cavity is read from file in the form (z,E(z)) with a step size h in z
721  ! in the SUPERFISH format: z(m) E(z) (V/m)
722  ! PART: the step size h may be divided in 'part' elements (with PART (= >) 1)
723  ! ATT: the field E(z) is multiplied by ATT and converted in MV/cm
724 
725  write (16, *) 'TYPE CODE: FIELD **********'
726  write (16, *) 'ELECTRIC FIELD (z, E(z) ) '
727  ! get filename of input file of the electromagnetic field in the form (z,E(z))
728  read (in, 3333) myfile(1:80)
729  ! write(16,*) 'Electromagnetic field file: ',myfile(1:80)
730  ! check if file is already open
731  iostats = int(ftell(20))
732  if (iostats==-1) then
733  ! file not yet open
734  open (20, file=myfile, status='unknown')
735  write (16, *) 'Opening field file: ', myfile(1:80)
736  ofeldf = myfile
737  else
738  if (ofeldf/=myfile) then
739  write (16, *) 'Closing field file: ', ofeldf
740  write (16, *) 'Opening field file: ', myfile(1:80)
741  close (20)
742  open (20, file=myfile, status='unknown')
743  ofeldf = myfile
744  end if
745  end if
746  read (in, *) att
747  ! omment write(16,*) ' partition of a step h: ',part,' field factor: ', att
748  ! conversion V/m (SUPERFISH) --> MV/cm
749  att = 1.e-08*att
750  write (16, *) ' * Read the cavity field from ', myfile(1:80)
751  call fieldcav(att)
752  write (16, *) '********************************'
753  else if (i==15) then
754  ! AFTER HARM: the field is read on the form of a Fourier series expansion
755  write (16, *) ' TYPE CODE: HARM **********'
756  write (16, *) 'ELECTRIC FIELD (Fourier series expansion)'
757  call rharm
758  write (16, *) '********************************'
759  else if (i==16) then
760  ! After BUNCHER: buncher as a single element
761  ! PV: Voltage
762  ! PDP: PHASE OF RF (deg)
763  ! PRLIM: aperture radius (cm)
764  ! PHARM: harmonic factor (bucher fq.)/(DTL freq.)
765  write (16, *) 'TYPE CODE:BUNCHER ************************'
766  read (in, *) pv, pdp, pharm, prlim
767  write (16, 7777) pv, pdp, prlim
768 7777 format (' BUNCHER CAVITY ', /, ' Voltage ', e12.5, ' MV', /, ' RF Phase ', e12.5, ' deg', &
769  ' Aperture Radius ', e12.5, ' cm')
770  kt3t = kt3t + 1
771  write (tif, 6007) kt3t, kt3t, pv, pdp, pharm
772 6007 format (' nt(', i4, ')=10, a(1,', i4, ')=', f9.5, ' , ', f9.2, ' , 1 , 1 , ', f5.1)
773  trace3t(kt3t) = tif
774  pdp = pdp*pi/180.
775  call bunparm(pv, pdp, pharm, prlim)
776  write (16, *) '********************************'
777  else if (i==17) then
778  ! AFTER RFQCL (single cell of a RFQ)
779  write (16, *) 'TYPE CODE:RFQCL ************************'
780  ! --- The parameter definitions of the cell are identical to the ones of TRACE3-D
781  ! VR02: Maximum intervane potentiel difference divided by square of average vanne displacement kV/(mm2)
782  ! AV : product of accelerating efficience and maximum intervane voltage (kV)
783  ! XLRFQ: cell length (mm)
784  ! XPHRFQ: phase of RF (deg)
785  ! TYPE: TYPE is one of the following
786  ! 0 = standard cell, no acceleration
787  ! 1 = standard cell, acceleration
788  ! 2 = fringing field, no acceleration
789  ! 3 = fringing field, acceleration
790 
791  read (in, *) vr02, av, xlrfq, xphrfq, type
792  ! ----- convert in MV , m in the array prfq(9)
793  ! ---- prfq(1) : VR02 ( MV/(m*m) )
794  ! ---- prfq(2) : AV (MV)
795  ! ---- prfq(3) : cell length (m)
796  ! ---- prfq(4) : phase of RF (deg)
797  ! ---- prfq(5) : TYPE
798  prfq(1) = vr02*1.e03
799  prfq(2) = av*1.e-03
800  prfq(3) = xlrfq*1.e-03
801  prfq(4) = xphrfq
802  prfq(5) = type
803  ! --- The space charge routine SCHEFF only is available
804  if (ichaes) then
805  if (iscsp<3) then
806  write (6, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
807  write (16, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
808  stop
809  end if
810  write (16, *) '***** beam current: ', beamc, ' mA'
811  end if
812  call rfq_o3
813  write (16, *) '********************************'
814  else if (i==18) then
815  ! AFTER NEWF:define a new frequency (Hertz)
816  if (imax==0) then
817  write (16, *) ' INIT TOF HAS TO BE PRECEEDED BY GBEAM', ' OR RDBEAM'
818  stop
819  end if
820  write (16, *) 'TYPE CODE:NEWF ************************'
821  read (in, *) fh1
822  ! record frequency change in view of trace3d file
823  fh1 = 2.*pi*fh1
824  fid = fh1/fh
825  ! adjust beam current
826  beamc = beamc*fh1/fh
827  rflvl = rflvl*fh1/fh
828  fh = fh1
829  write (16, *) ' NEW FREQUENCY : ', fh/(2.*pi), ' Hertz'
830  else if (i==19) then
831  ! AFTER NREF: define a new syncronous particle
832  ! ---- DEPHAS: the change of phase (DEG)
833  ! ---- DEW : the change of kinetic energy (see IREFW)
834  ! ---- follow two falgs, IREF and IREFW
835  ! ---- IF IREF=0: RELATIVE TO the previous synchronous particle
836  ! ---- IF IREF=1: RELATIVE TO the previous COG
837  ! ---- IF IREFW=0: DEWREF is in dW/W
838  ! ---- IF IREFW=1: DEWREF is in dW (MeV)
839  write (16, *) ' TYPE CODE:NREF ***********'
840  read (in, *) dephas, dewref, iref, irefw
841  call refer
842  write (16, *) '********************************'
843  else if (i==20) then
844  ! AFTER SCDYNAC
845  ! ISCSP: METHOD FOR SPACE CHARGE COMPUTATIONS
846  ! ISCSP=1 HERSC METHOD
847  ! ISCSP=2 SCHERM METHOD
848  ! ISCSP=3 SCHEFF METHOD
849  write (16, *) ' TYPE CODE:SCDYNAC ***********'
850  read (in, *) iscsp
851  ! sce10 =1 : call in quads,solenoids,accelarating elements
852  ! sce10 =2 : call in drifts,accelarating elements
853  ! sce10 =3 : call in quads,solenoids,drifts,accelarating elements
854  ! BEAM CURRENT IN ma
855  read (in, *) beamc, sce10
856  if (.not. xiset) then
857  kt3h = kt3h + 1
858  write (tif, 7001) beamc
859 7001 format (' XI= ', f9.4)
860  trace3h(kt3h) = tif
861  xiset = .true.
862  end if
863  if (iscsp<=1) write (16, *) 'HERSC method '
864  if (iscsp==2) write (16, *) 'SCHERM method '
865  if (iscsp==3) write (16, *) 'SCHEFF method '
866  if (iscsp>3) then
867  write (16, *) 'Error in SCDYNAC iscsp: ', iscsp
868  stop
869  end if
870  write (16, *) ' Beam current : ', beamc, ' mA'
871  ect = 4.
872  ichaes = .true.
873  if (iscsp<=1) then
874  ! initialise the routine HERSC
875  if (iscsp==1) ini = 0
876  if (iscsp<1) ini = -1
877  call hersc(ini)
878  iscsp = 1
879  end if
880  ! --- SCHERM, read third line as dummy
881  if (iscsp==2) read (in, *) idum
882  ! --- SCHEFF
883  ! initialise the mesh of routine SCHEFF
884  if (iscsp==3) then
885  call schfdyn
886  end if
887  if (beamc==0.) ichaes = .false.
888  write (16, *) '****************************'
889  else if (i==21) then
890  ! AFTER SCDYNEL: space charge computations in the current position (i.e.bending magnet)
891  ! XTRANS is the acting lenght of the beam self-fields (cm)
892  write (16, *) ' TYPE CODE:SCDYNEL ****'
893  read (in, *) xtrans
894  call cesp(xtrans)
895  write (16, *) '****************************'
896  else if (i==22) then
897  ! AFTER SCPOS : change the position of space charge computation in gaps or cavities
898  write (16, *) ' TYPE CODE:SCPOS(space charge position)****'
899  read (in, *) xpsc
900  if (xpsc>=1.) xpsc = .5
901  write (16, *) '****************************'
902  else if (i==23) then
903  ! AFTER TILT:rotation and shift of beam ellipsoid
904  ! ICG : = 1 => REFERENCE PARTICLE IS THE C.O.G. OF THE BEAM
905  ! ICG : = 0 => IT IS DISTINCT FROM THE C.O.G.
906  write (16, *) ' TYPE CODE:TILT *********************'
907  read (in, *) icg
908  read (in, *) tipha, tix, tiy, shifw, shifp
909  call tiltbm(icg)
910  write (16, *) '****************************'
911  else if (i==24) then
912  ! AFTER TILZ: tilt in the plane (x,z) around the c.o.g. of the upright ellipse
913  write (16, *) ' TYPE CODE:TILZ *********************'
914  read (in, *) tilta
915  call tiltz(tilta)
916  write (16, *) '****************************'
917  else if (i==25) then
918  ! AFTER CHANGREF: change of reference frame
919  write (16, *) ' TYPE CODE:CHANGREF *********************'
920  call chrefe
921  else if (i==26) then
922  ! After TOF:
923  ! --- the T.O.F may be activated in the dynamics of bunchers, cavities and acc. gaps
924  ! --- Entry: indic and icor
925  ! --- indic = 0 : the T.O.F is activated, otherwise it is passive
926  ! --- icor = 0 : no adjustement on the phase offset, otherwise adjustments are automatically made on the
927  ! phase offset
928  write (16, *) ' TYPE CODE: TOF ************'
929  call rmami
930  write (16, *) '****************************'
931  else if (i==27) then
932  ! AFTER REJECT: defining limits in X,X',Y,Y',Z,Z'
933  ! ---- aperture of the Beam
934  ! ---- WDISP: in half dispersion
935  ! ------ IF IFW=0 ==> WDISP in (+-) dW/W
936  ! ------ IF IFW=1 ==> WDISP in (+-) dW (MeV)
937  ! ------ IF IFW=10 ==> wdisp = dW/W relative to REF
938  ! ------ IF IFW=11 ==> wdisp = dW relative to REF
939  ! ---- WPHAS: in half phase (+-) deg
940  ! ---- WX : in x-direction (+-) cm
941  ! ---- WY : in y-direction (+-) cm
942  ! ---- RLIM : in radius (cm)
943  write (16, *) ' TYPE CODE:REJECT*********************'
944  read (in, *) ifw, wdisp, wphas, wx, wy, rlim
945  if (ifw==0) then
946  write (16, 1050) wdisp, wphas, wx, wy, rlim
947  else
948  write (16, 1051) wdisp, wphas, wx, wy, rlim
949  end if
950 1050 format (5x, ' *** BEAM SIZE LIMITS ', /, 4x, ' 1/2 dW/W :', e12.5, ' 1/2 PHASE(DEG) :', e12.5, /, 4x, &
951  ' 1/2 x (cm) :', e12.5, ' 1/2 y(cm) :', e12.5, ' RADIUS (cm) :', e12.5)
952 1051 format (5x, ' *** BEAM SIZE LIMITS ', /, 4x, '1/2 dW (MeV) :', e12.5, ' 1/2 PHASE(DEG) :', e12.5, /, 4x, &
953  ' 1/2 x (cm) :', e12.5, ' 1/2 y(cm) :', e12.5, ' RADIUS (cm) :', e12.5)
954  ! ---- convert WPHAS in rad
955  wphas = wphas*pi/180.
956  write (16, *) '****************************'
957  else if (i==28) then
958  ! AFTER ZROT : beam rotation
959  ! The transverse coordinates x and y may be rotated through an
960  ! angle ZROTA(deg).The positive sense of ratation is clockwise
961  ! about the positive z axis
962  write (16, *) ' TYPE CODE:ZROT*********************'
963  read (in, *) zrota
964  call zrotat(zrota)
965  write (16, *) '****************************'
966  else if (i==29) then
967  ! after ALINER: ALIGNMENT errors IN X,X',Y,Y'
968  ! XL,YL (cm) XPL,YPL (mrad)
969  write (16, *) ' TYPE CODE:ALINER*********************'
970  read (in, *) xl, yl, xpl, ypl
971  call aliner
972  write (16, *) '****************************'
973  else if (i==30) then
974  ! AFTER ACCEPT: Determination of the input acceptance for the structure
975  write (16, *) ' TYPE CODE:ACCEPT*********************'
976  acpt = .true.
977  call accept
978  acpt = .false.
979  write (16, *) '****************************'
980  else if (i==31) then
981  ! AFTER EMIT Print emittance data in the file 'dynac.short'
982  call emiprt(0)
983  else if (i==32) then
984  ! AFTER EMITGR: emittance plots
985  ! PLOTS IN XX', YY', XY AND ZZ'
986  write (16, *) ' TYPE CODE:EMITGR*********************'
987  igrprm = 0
988  call ytzp
989  write (16, *) '****************************'
990  else if (i==33) then
991  ! AFTER COMMENT
992  ! allows for comments in the input data file
993  write (16, '(a8)') kley
994  read (in, '(A)') cmnt(1:80)
995  write (16, '(A)') cmnt(1:80)
996  else if (i==34) then
997  ! AFTER WRBEAM: prints coordinates of particles on output files
998  write (16, *) 'WRBEAM output coordinates of particles'
999  ! irec:flag irec=0 the phase is recentered with regard to the c.o.g
1000  ! irec<>0 the phase is not recentered around the c.o.g
1001  read (in, '(A)') wfile
1002  write (16, '(A)') 'Distribution will be written to ', wfile
1003  read (in, *) irec, iflg
1004  ! iflag=0
1005  call prbeam(iflg, wfile)
1006  write (16, *) '****************************'
1007  else if (i==35) then
1008  ! AFTER ENVEL: plot the longitudinal and the tranverse envelope of the beam
1009  write (16, *) ' ENVEL *********************'
1010  call profil
1011  write (16, *) '****************************'
1012  else if (i==36) then
1013  ! AFTER CHASE:Temporary elimination of most distant particles for statistical purposes
1014  write (16, *) ' TYPE CODE:CHASE ********************'
1015  call chase
1016  write (16, *) '****************************'
1017  else if (i==37) then
1018  ! AFTER RWFIELD : rewinds the file 'field.txt'
1019  rewind(20)
1020  else if (i==38) then
1021  ! AFTER RANDALI : generates random errors in alignments
1022  ! XL,YL (cm) XPL,YPL (mrad)
1023  ! ilier = 0 stop the effects of the random misalignment
1024  write (16, *) ' TYPE CODE:RANDALI*********************'
1025  read (in, *) ilier
1026  if (ilier==0) then
1027  ialin = .false.
1028  write (16, *) '****************************'
1029  ! go to 200
1030  else
1031  ialin = .true.
1032  read (in, *) xl, yl, xpl, ypl
1033  end if
1034  write (16, *) '****************************'
1035  else if (i==39) then
1036  ! AFTER TWQA generates systematic or random twist of quadrupoles
1037  ! QTWIST: rotation about Y axis (deg)
1038  ! IQRAND: =0 systematic twist, otherwise random twist
1039  write (16, *) ' TYPE CODE TWQA*********************'
1040  read (in, *) iqrand, qtwist
1041  itwist = .true.
1042  if (abs(qtwist)<=1.e-20) itwist = .false.
1043  write (16, *) '****************************'
1044  else if (i==40) then
1045  ! AFTER EMIPRT : print the beam characteristics in the disk(tape12, file='dynac.short')
1046  ! --- the beam characteristics are systematically print after:
1047  ! cavities, accelerating gaps, bunchers, electrons gun, rfq
1048 
1049  ! IEMQESG : =0 stop the prints for all optical lenses
1050  ! =1 after all optical lenses apart from positive drifts
1051  ! =2 after all optical lenses and positive drifts
1052  ! =3 after quads, solen.,positive drifts and accel. elements
1053  iemgrw = .true.
1054  read (in, *) iemqesg
1055  if (iemqesg==0) iemgrw = .false.
1056  else if (i==41) then
1057  ! AFTER MMODE: systematic or random error on the phase offset and on the level of the field
1058  ! --- MMODE is only acting on particles in the bunch (no change of the reference)
1059  ! --- ENTRY: ierpf , vphase , vfield
1060  ! --- ierpf: flag
1061  ! --- IF: ierpf = 0 ===> stop the type code effects
1062  ! --- ierpf = 1 ===> systematic error
1063  ! --- ierpf > 1 ===> random error
1064  ! --- vphase (deg): error added to the nominal phase offset
1065  ! --- vfield (%) : error added to the level of the electric field
1066  ! --- (new phase offset) = (previous phase offset) + vphase
1067  ! --- (new level of field) = (previous level of field) * (1.+ vfield/100)
1068  write (16, *) ' TYPE CODE MMODE*********************'
1069  read (in, *) ierpf, vphase, vfield
1070  if (ierpf==0) then
1071  vphase = 0.
1072  vfield = 0.
1073  end if
1074  if (ierpf==1) write (16, 4279) vphase, vfield
1075 4279 format (2x, 'systematic error on phase offset: ', e12.2, ' deg', /, 2x, &
1076  'systematic error on level of field: ', e12.5, ' %')
1077  if (ierpf>1) write (16, 4290) vphase, vfield
1078 4290 format (2x, 'maximun randon error on phase offset: ', e12.2, ' deg', /, 2x, &
1079  'maximum random error on level of field: ', e12.5, ' %')
1080  vfield = vfield/100.
1081  write (16, *) '****************************'
1082  else if (i==42) then
1083  ! --- AFTER RFQPTQ
1084  write (16, *) 'TYPE CODE:RFQPTQ ************************'
1085  write (6, *)
1086  ! -- ENTRIES:
1087  ! --- ENTRY 1: input file 'myfile' contains the geometry of the RFQ (unit 27)
1088  ! --- ENTRY 2: nceltot
1089  ! nceltot: number of cells (may be less than the total number of cells)
1090  ! --- ENTRY 3: tvolt avolt fph
1091  ! ---- tvolt: factor applied to intervane-voltage Vref of the synchronous particle (in %)
1092  ! ---- avolt: factor applied to intervane-voltage Vpart for particles (in %)
1093  ! Vref = Vref(1 + tvolt/100)
1094  ! Vpart = Vpart(1 + avolt/100)
1095  ! --- fph: factor applied to the phase at entrance of cells in the file myfile in %)
1096  ! (phase at entrance of cells)= (1 + fph/100) X (phase in myfile)
1097  ! NOTE: fph is only available for cells of type = 0, type = 2 (type = E) or type = 5 (type R)
1098  ! --- pib > 0: shift the particles at the entrance of the RFQ inside (+/-) pi w.r.t.the synchronous
1099  ! particle
1100  ! --- pib = 0: no action
1101 
1102 
1103  ! related files:
1104 
1105  ! 'rfq_list.data' : list of parameters of the RFQ
1106 
1107  ! 'rfq_listmid.data' : list of phases at input & middle of each RFQ cell
1108 
1109  ! 'rfq_lost.data' : lists where particles are lost in the RFQ
1110 
1111  ! 'rfq_coeflist.data' list of coefficients
1112  read (in, 3333) myfile(1:80)
1113  write (16, *) 'RFQ input data file: ', myfile(1:80)
1114  open (27, file=myfile, status='unknown')
1115  open (70, file='rfq_list.data', status='unknown')
1116  open (75, file='rfq_coef.data', status='unknown')
1117  open (49, file='rfq_lost.data', status='unknown')
1118  open (89, file='rfq_listmid.data', status='unknown')
1119  read (in, *) nceltot
1120  read (in, *) tvolt, avolt, fph, pib
1121  write (16, 5279) nceltot, tvolt, avolt
1122 5279 format (' RFQ number of cells: ', i5, /, ' factor on intervane voltage (reference):', e12.5, ' %', /, &
1123  ' factor on intervane voltage (bunch):', e12.5, ' % ')
1124  tvolt = tvolt/100.
1125  avolt = avolt/100.
1126  fph = (1.+fph/100.)
1127  if (ichaes) then
1128  write (16, *) '***** beam current: ', beamc, ' mA'
1129  if (iscsp<3) then
1130  write (6, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
1131  write (16, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
1132  stop
1133  end if
1134  end if
1135  call cpardyn(pib)
1136  write (6, *)
1137  write (16, *) '****************************'
1138  else if (i==43) then
1139  ! --- AFTER STRIPPER: stripper foils
1140  ! --- ( based on the works of D.A. Eastham, ref. )
1141  ! --- available for 'slow' hadron particles
1142  ! --- STRIPPER FOILS PARAMETERS:
1143  ! --- qs : charge (unit of charge)
1144  ! --- atms: atomic mass
1145  ! --- ths : thickness of the foils (g/cm**2)
1146  ! --- PARTICLES
1147  ! *2010-12-02 Use Baron formula for charge state distribution in case of carbon foils
1148  ! --- anp : atomic number of the projectile
1149  ! --- nqst: number of charge states after the stripper
1150  ! --- sqst: array holding the nsqt charge states
1151  ! --- qop : charge of particles after crossing the stripper foils (unit of charge)
1152  ! --- the atomic mass of particles (atm) is the one given in INPUT or in RDBEAM
1153  write (16, *) 'TYPE CODE:STRIPPER ***********************'
1154  read (in, *) qs, atms, ths, anp
1155  call stripp
1156  write (16, *) '****************************'
1157  else if (i==44) then
1158  ! AFTER STEER: thin steering element
1159  ! ---- PARAMETERS ARE INTEGRATED FIELD fld, nvf
1160  ! fld in units of (Tm) for magnetic steerer
1161  ! fld in units of (kV*m/m) for electrostatic steerer
1162  ! (Voltage * length / plate separation)
1163  ! if nvf=0, horizontal magnetic steerer
1164  ! if nvf=1, vertical magnetic steerer
1165  ! if nvf=2, horzontal electrostatic steerer
1166  ! if nvf=3, vertical electrostatic steerer
1167  write (16, *) ' TYPE CODE:STEER*********************'
1168  read (in, *) fld, nvf
1169  call steer(fld, nvf)
1170  write (16, *) '****************************'
1171  ! start of writes in file '.short' for steerer
1172  idav = idav + 1
1173  iitem(idav) = 9
1174  dav1(idav, 1) = fld
1175  dav1(idav, 2) = float(nvf)
1176  dav1(idav, 3) = davtot*10.
1177  ! end daves
1178  else if (i==45) then
1179  ! AFTER ZONES: specify zones of different colours in the bunch
1180  write (16, *) ' TYPE CODE:ZONES*********************'
1181  init = 1
1182  call area(init)
1183  write (16, *) '****************************'
1184  else if (i==46) then
1185  ! AFTER PROFGR: X-Z and Y-Z scatter plots,(X,Y,Z) and (Xp,Yp,Zp) profiles
1186  write (16, *) ' TYPE CODE:PROFGR*********************'
1187  igrprm = 0
1188  if (igrprm==0) then
1189  ! READ GRAPH TITLE
1190  read (in, 6620) text
1191 6620 format (a)
1192  ! idwdp=0 cog=ref in XZ,YZ plots (for instance for Alvarez structure)
1193  ! idwdp=1 cog<>ref in XZ,YZ plots (for instance for IH structrure)
1194  ! iskale=0 vertical scale on profile plots is NOT a log scale
1195  ! iskale=1 vertical scale on profile plots IS a log scale
1196  read (in, *) idwdp, iskale
1197  ! READ GRAPH LIMITS INTO GLIM(J,K), J=GRAPH NUMBER
1198  ! K=1 HOR. LIMIT , K=2 VERT. LIMIT
1199  read (in, *) glim(3, 1), glim(3, 2), glim(4, 1), glim(4, 2)
1200  end if
1201  call grcomp(text, iskale)
1202  write (16, *) '****************************'
1203  else if (i==47) then
1204  ! AFTER SECORD : second order matrix for optical lenses
1205  write (16, *) '*****************************************'
1206  write (16, *) ' SECOND ORDER IN BEAM TRANSPORT**********'
1207  iseor = .true.
1208  write (16, *) '*****************************************'
1209  else if (i==48) then
1210  ! AFTER RASYN : Radiation exitation in bending magnets (only for electrons)
1211  write (16, *) ' SYNCHRTRON RADIATION IN BENDING MAGNET****'
1212  iraysh = .true.
1213  write (16, *) '*******************************************'
1214  else if (i==49) then
1215  ! AFTER FDRIFT : Divide a drift length in partial drifts (for space charge computations)
1216  write (16, *) ' TYPE CODE:FDRIFT*********************'
1217  ! XL : Total drift length (cm)
1218  ! NPART : number of partial drifts
1219  ! IMIT : if IMIT not equal zero,print emittance datas in the file 'short.txt'
1220  read (in, *) xl, npart, imit
1221  dl = xl/float(npart)
1222  write (16, *) ' total drift length : ', xl, ' cm divided in : ', npart, ' drifts of : ', dl, ' cm'
1223  call fdrift(xl, npart, imit)
1224  write (16, *) '*******************************************'
1225  else if (i==50) then
1226  ! AFTER FSOLE: solenoid the magnetic field is read from disk in the form (z,B(z))
1227  ! unities: z (m), B(z) kG
1228  ! BCRET : coefficient multiplier, the magnetic is: B(z) * BCRET
1229  ! sign field convention like in the code TRANSPORT
1230  write (16, *) 'TYPE CODE FSOLE*****************'
1231  read (in, 3333) myfile(1:80)
1232  ! unit 25 corresponds to an input file giving solenoid magnetic field(s) in the form (z,B(z))
1233  ! check if file is already open
1234  iostats = int(ftell(25))
1235  if (iostats==-1) then
1236  ! file not yet open
1237  open (25, file=myfile, status='unknown')
1238  write (16, *) 'Opening solenoid field file: ', myfile(1:80)
1239  ofelds = myfile
1240  else
1241  if (ofeldf/=myfile) then
1242  write (16, *) 'Closing solenoid field file: ', ofelds
1243  write (16, *) 'Opening solenoid field file: ', myfile(1:80)
1244  close (25)
1245  open (25, file=myfile, status='unknown')
1246  ofelds = myfile
1247  end if
1248  end if
1249  read (in, *) bcret, intgr
1250  write (16, 990) intgr
1251 990 format ('*** SOLENOID WITH ARBITRARY MAGNETIC FIELD ', /, 5x, 'PARTITION IN: ', i4, ' ELEMENTARY SOLENOIDS')
1252  call solfield(bcret, intgr)
1253  write (16, *) '********************************'
1254  else if (i==51) then
1255  ! AFTER EGUN:
1256  ! Only the SCHEFF routine is avalaible in the routine EGUN
1257  ! omment ichaes=.false.
1258  write (16, *) 'TYPE CODE EGUN*****************'
1259  ! unit 22 corresponds to an input file giving egun field (z,E(z)) E(z) normalised
1260  read (in, 3333) myfile(1:80)
1261  write (16, *) 'Egun field file: ', myfile(1:80)
1262  open (22, file=myfile, status='unknown')
1263  ! follows the particle ifpt (not active)
1264  ! not actived read(in,*)ifpt
1265  ! fmult: field factor
1266  read (in, *) fmult, indp
1267  if (.not. ichaes) indp = 1
1268  ! indp: number of space charge computations to be made in the EGUN
1269  ! indp = 1 : 8 space charge computations. The EGUN field is divided in 16 elements
1270  ! indp = 2 : 16 space charge computations. in 32 elements
1271  ! indp = 3 : 32 space charge computations. in 64 elements
1272  if (ichaes) then
1273  write (16, *) '***** beam current: ', beamc, ' mA'
1274  if (iscsp<3) then
1275  write (6, *) '*** HERSC and SCHERM cannot be used', 'with EGUN'
1276  write (16, *) '*** HERSC and SCHERM cannot be used with', 'with EGUN'
1277  stop
1278  end if
1279  end if
1280  call egun(fmult, indp)
1281  write (16, *) '*******************************************'
1282  else if (i==52) then
1283  ! AFTER COMPRES
1284  ! Do so by shifting particles belonging to the same bunch outside the (+/-) pib/2 (deg) window
1285  ! w.r.t.the COG to inside the (+/-) pib/2 window w.r.t.the COG
1286  write (16, *) ' TYPE CODE: COMPRES ********'
1287  ! --- pib (deg)
1288  read (in, *) pib
1289  pib = pib/2.
1290  write (16, 1890) pib
1291  call compress(pib)
1292 1890 format ('*** shift particles inside +/- ', e12.5, 'deg')
1293  write (16, *) '*******************************************'
1294  else if (i==54) then
1295  ! AFTER REFCOG:
1296  ! ISHIFT = 0: the synchronous particle and the cog are coinciding (shift = false)
1297  ! ISHIFT = 1: the synchronous particle and the cog are separated (shift = true)
1298  ! ISHIFT = 2: at the start the TOF of synchronous particle is the TOF of the cog
1299  ! after synchronous particle and cog are separated (shift = true)
1300  ! (at the begining shift = false)
1301  write (16, *) ' TYPE CODE:REFCOG *********************'
1302  read (in, *) ishift
1303  if (ishift==0) then
1304  shift = .false.
1305  write (16, *) ' Synchronous particle is the COG of the', ' bunch'
1306  obref = vref/vl
1307  otref = tref
1308  tcog = 0.
1309  wcog = 0.
1310  do ijp = 1, ngood
1311  wcog = wcog + f(7, ijp)
1312  tcog = tcog + f(6, ijp)
1313  end do
1314  wcog = wcog/float(ngood)
1315  tcog = tcog/float(ngood)
1316  gcog = wcog/xmat
1317  bcog = sqrt(gcog*gcog-1.)/gcog
1318  vref = bcog*vl
1319  tref = tcog
1320  fcpi = fh*180./pi
1321  write (16, 5433) obref, otref*fcpi, vref/vl, tref*fcpi, bcog, tcog*fcpi
1322 5433 format (' old ref. beta: ', e12.5, ' TOF: ', e12.5, ' deg', /, ' new ref. beta: ', e12.5, ' TOF: ', e12.5, &
1323  ' deg', /, ' COG beta: ', e12.5, ' TOF: ', e12.5, ' deg')
1324  ! write(16,*) 'old TTVOL (deg): ',ottvols*fcpi
1325  ! write(16,*) 'new TTVOL (deg): ',ttvols*fcpi
1326  end if
1327  if (ishift==1) then
1328  shift = .true.
1329  write (16, *) ' Synchronous particle and COG of the ', 'bunch are independent'
1330  end if
1331  if (ishift>1) then
1332  write (16, *)
1333  write (16, *) ' Synchronous particle and COG of the ', &
1334  'bunch are independent, but initially TOF and energy', &
1335  'of the synchronous particle are the ones of the ', 'bunch'
1336  shift = .true.
1337  ! --- the reference is the cog
1338  obref = vref/vl
1339  otref = tref
1340  wcog = 0.
1341  tcog = 0.
1342  do ijp = 1, ngood
1343  wcog = wcog + f(7, ijp)
1344  tcog = tcog + f(6, ijp)
1345  end do
1346  wcog = wcog/float(ngood)
1347  tcog = tcog/float(ngood)
1348  gcog = wcog/xmat
1349  bcog = sqrt(gcog*gcog-1.)/gcog
1350  vref = bcog*vl
1351  tref = tcog
1352  ottvols = ttvols
1353  if (itvol) ttvols = tref
1354  fcpi = fh*180./pi
1355  ! write(16,5420)obref,otref*fcpi,obref,tref*fcpi
1356  write (16, 5420) obref, otref*fcpi, vref, tref*fcpi
1357 5420 format (' old ref. beta: ', e12.5, ' tref: ', e12.5, ' deg', /, ' new ref. beta: ', e12.5, ' tref: ', &
1358  e12.5, ' deg')
1359  write (16, *) 'old TTVOL (deg): ', ottvols*fcpi
1360  write (16, *) 'new TTVOL (deg): ', ttvols*fcpi
1361  end if
1362  write (16, *) '****************************'
1363  else if (i==55) then
1364  ! AFTER FPART:
1365  ! --- a given particle is followed in the accelerating elements
1366  ! --- ICONT : the number of the particle followed in accelerating elements
1367  write (16, *) ' TYPE CODE:FPART *********************'
1368  read (in, *) icont
1369  write (16, *) ' the particle:', icont, ' is followed'
1370  write (16, *) '****************************'
1371  else if (i==56) then
1372  ! AFTER QUAELEC: electric quadrupole
1373  ! VOLT: voltage at pole tip (kV)
1374  ! XLQUA: effective length (cm)
1375  ! RS: radial distance of pole tip from axis (cm)
1376  write (16, *) 'TYPE CODE:QUALEC**********'
1377  read (in, *) xlqua, volt, rs
1378  call qelec(volt, xlqua, rs)
1379  write (16, *) '********************************'
1380  else if (i==57) then
1381  ! AFTER QUAFK: quadrupole (magnetic or electric)
1382  ! ITYQU: ITYQU = 0 electric quadrupole , otherwise magnetic quadrupole
1383  ! ARG: K2 (cm-2)
1384  ! XLQUA: effective length (cm)
1385  ! RS: radial distance of pole tip from the axis (cm)
1386  write (16, *) 'TYPE CODE:QUAFK**********'
1387  read (in, *) ityqu, arg, xlqua, rs
1388  call qfk(ityqu, arg, xlqua, rs)
1389  write (16, *) '********************************'
1390  else if (i==58) then
1391  ! AFTER CAVNUM: numerical computation of multicell cavities
1392  ! the electromagnetic field can be read:on the disk in the form (z,E(z))
1393  ! or from the type code: HARM in the form of a Fourier series expansion
1394  write (16, *) 'TYPE CODE:CAVNUM **********'
1395  call cavnum
1396  write (16, *) '********************************'
1397  else if (i==59) then
1398  ! AFTER EDFLEC: ELECTROSTATIC DEFLECTOR
1399  ! --- Input parameters
1400  ! radial radius (cm)
1401  ! bend angle (deg)
1402  ! radii: vertical (radial) radii of curvature (cm)
1403  call e_deflec
1404  write (16, *) '********************************'
1405  else if (i==60) then
1406  ! AFTER EMITL Print emittance datas in the file 'dynac.short' but
1407  ! also read label to written to dynac.short
1408  read (in, '(A)') shortl
1409  call emiprt(1)
1410  else if (i==61) then
1411  ! After RFKICK: Electric RF kicker
1412  ! PV: Voltage Factor (Voltage (kV) * electrode length (m) / gap (m))
1413  ! PDP: PHASE OF RF (deg)
1414  ! PHARM: harmonic factor (bucher fq.)/(DTL freq.)
1415  ! NVF: 0 = horizontal, 1 = vertical
1416  write (16, *) 'TYPE CODE:RFKICK ************************'
1417  read (in, *) pv, pdp, pharm, nvf
1418  plane = 'horizontal'
1419  if (nvf==1) plane = 'vertical '
1420  write (16, 7779) pv, pdp, plane
1421 7779 format (' RF Kicker ', /, ' Voltage Factor', e12.5, ' kV*m/m', /, ' RF Phase ', e12.5, ' deg', ' Type: ', &
1422  a10)
1423  pdp = pdp*pi/180.
1424  call rfkick(pv, pdp, pharm, nvf)
1425  write (16, *) '********************************'
1426  else if (i==62) then
1427  ! AFTER FIRORD : first order matrix for optical lenses
1428  write (16, *) '*****************************************'
1429  write (16, *) ' FIRST ORDER IN BEAM TRANSPORT**********'
1430  iseor = .false.
1431  write (16, *) '*****************************************'
1432  else if (i==63) then
1433  ! AFTER DCBEAM : select DC or bunched beam
1434  read (in, *) iscont
1435  write (16, *) '****************************'
1436  if (iscont==1) then
1437  ifcont = .true.
1438  write (16, *) ' DC BEAM SELECTED **********'
1439  else if (iscont==0) then
1440  ifcont = .false.
1441  write (16, *) ' BUNCHED BEAM SELECTED ********'
1442  end if
1443  write (16, *) '****************************'
1444  else if (i==64) then
1445  ! AFTER T3D : request TRACE3D input file
1446  t3d = .true.
1447  write (16, *) '**************************************'
1448  write (16, *) '* TRACE3D INPUT FILE WILL BE WRITTEN *'
1449  write (16, *) '**************************************'
1450  else if (i==53) then
1451  ! AFTER STOP: mandatory, stop the computations
1452  write (16, 100) kle(i)
1453  exit
1454  end if
1455  else
1456  ! key not found, go to STOP
1457  indic = 999
1458  write (66, *) indic
1459  write (16, 111) kley
1460  write (6, 111) kley
1461  exit
1462  end if
1463  end do
1464  ! write trace file (if requested)
1465  if (t3d) then
1466  ! write trace file (header part)
1467  open (itout, file='for_trace3d.t3d', status='unknown')
1468  write (itout, '(A)') trace3h(1)
1469  write (itout, 1990) kt3t, kt3t, kt3t
1470 1990 format (' N1= 1, N2= ', i4, ', NEL1= 1, NEL2= ', i4, ', NP1= 1, NP2= ', i4)
1471  do i = 2, kt3h
1472  write (itout, '(A)') trace3h(i)
1473  end do
1474  write (itout, 1992)
1475 1992 format (' PQEXT= 2.5, ICHROM= 0, IBS= 0, SMAX= 2.0')
1476  write (itout, 1993)
1477 1993 format (' XM= 15.00, XPM= 50.00, YM= 15.00')
1478  write (itout, 1994)
1479 1994 format (' XMI= 15.00, XPMI= 50.00, XMF= 15.00, XPMF= 25.00')
1480  write (itout, 1995)
1481 1995 format (' DPM= 90.0, DWM= 50.00, DPP= 90.00')
1482  write (itout, 1996)
1483 1996 format (' DPMI= 90.0, DPMF= 35.00, DWMI= 50.0, DWMF= 200.0')
1484  ! write trace file (beam line part)
1485 
1486  ! deal with negative drifts (typical within DTLs)
1487  ! if the current drift is negative, then see if there is a drift before or
1488  ! after it. If so, add the 2 drifts, devide by 2 and put this result in both
1489  ! drifts
1490  do k = 2, kt3t - 1
1491  trdrifa = 0.
1492  trdrifb = 0.
1493  tif = trace3t(k)
1494  tifb = trace3t(k-1)
1495  tifa = trace3t(k+1)
1496  if (tif(12:13)==' 1' .and. tifb(12:13)==' 1') then
1497  read (tif(28:50), *) trdrift
1498  if (trdrift<0.) then
1499  read (tifb(28:50), *) trdrifb
1500  if (trdrifb>0.) then
1501  aver = (trdrifb+trdrift)/2.
1502  trdrifb = aver
1503  trdrift = aver
1504  ! write(6,*) k,'beforeb',tif(12:13),trdrift,trdrifb
1505  write (fdrft, 555) trdrift
1506 555 format (f12.6)
1507  tif(28:40) = fdrft
1508  write (fdrft, 555) trdrifb
1509  tifb(28:40) = fdrft
1510  trace3t(k) = tif
1511  trace3t(k-1) = tifb
1512  end if
1513  end if
1514  else if (tif(12:13)==' 1' .and. tifa(12:13)==' 1') then
1515  read (tif(28:50), *) trdrift
1516  if (trdrift<0.) then
1517  read (tifa(28:50), *) trdrifa
1518  if (trdrifa>0.) then
1519  aver = (trdrifa+trdrift)/2.
1520  trdrifa = aver
1521  trdrift = aver
1522  ! write(6,*) k,'aftera',tif(12:13),trdrift,trdrifa
1523  write (fdrft, 555) trdrift
1524  tif(28:40) = fdrft
1525  write (fdrft, 555) trdrifa
1526  tifa(28:40) = fdrft
1527  trace3t(k) = tif
1528  trace3t(k+1) = tifa
1529  end if
1530  end if
1531  end if
1532  end do
1533  do k = 1, kt3t
1534  write (itout, '(A)') trace3t(k)
1535  end do
1536  write (itout, '(A)') ' $END'
1537  end if
1538  call daves
1539  call eugwrt
1540  call cpu_time(exfin)
1541  exfin = exfin - exstrt
1542  call mytime(iitime)
1543  write (6, *)
1544  if (mg) then
1545  ! using MINGW style gfortran format: 03/30/10 20:51:06 (10 is 2010)
1546  text(1:4) = ' '
1547  if (iitime(1:2)=='01') text(5:7) = 'Jan'
1548  if (iitime(1:2)=='02') text(5:7) = 'Feb'
1549  if (iitime(1:2)=='03') text(5:7) = 'Mar'
1550  if (iitime(1:2)=='04') text(5:7) = 'Apr'
1551  if (iitime(1:2)=='05') text(5:7) = 'May'
1552  if (iitime(1:2)=='06') text(5:7) = 'Jun'
1553  if (iitime(1:2)=='07') text(5:7) = 'Jul'
1554  if (iitime(1:2)=='08') text(5:7) = 'Aug'
1555  if (iitime(1:2)=='09') text(5:7) = 'Sep'
1556  if (iitime(1:2)=='10') text(5:7) = 'Oct'
1557  if (iitime(1:2)=='11') text(5:7) = 'Nov'
1558  if (iitime(1:2)=='12') text(5:7) = 'Dec'
1559  text(8:8) = ' '
1560  text(9:10) = iitime(4:5)
1561  text(11:13) = ' 20'
1562  text(14:15) = iitime(7:8)
1563  text(16:19) = ' at '
1564  text(20:27) = iitime(10:17)
1565  else
1566  text(1:11) = iitime(1:11)
1567  text(12:15) = iitime(21:24)
1568  text(16:19) = ' at '
1569  text(20:27) = iitime(12:19)
1570  end if
1571  write (12, *) 'Stopped on ', text(1:27)
1572  write (16, *) 'Stopped on ', text(1:27)
1573  write (6, '(A11,A27)') 'Stopped on ', text(1:27)
1574  write (6, '(A12,F14.6,A4)') 'Executed in ', exfin, ' sec'
1575  write (16, 101)
1576  ! close input files
1577  close (10)
1578  close (20)
1579  close (22)
1580  close (25)
1581  close (27)
1582  close (55)
1583  ! close output files
1584  ! files actived in the code
1585  close (16)
1586  close (12)
1587  close (71)
1588  close (50)
1589  close (61)
1590  close (60)
1591  close (11)
1592  close (66)
1593  close (75)
1594  close (49)
1595  ! files not actived in the code
1596  ! SV 24/08/2015
1597  close (13)
1598  ! old close(14)
1599  ! omment close(15)
1600  ! omment close(17)
1601  ! omment close(18)
1602  ! omment close(19)
1603  ! omment close(21)
1604  ! omment close(49)
1605  close (70)
1606  stop
1607 111 format ('STOP ON KEY: ', a8, ' (invalid key)')
1608 100 format (/, 40x, ' STOP on key : ', a8, //)
1609 101 format ('*******************************************************', '*****************')
1610  end program dynac
1611  ! *******************************************************************
1612  ! SUBROUTINE mytime
1613  ! get system time and convert it to an ascii string
1614  ! *******************************************************************
1615  subroutine mytime(iitime)
1616  implicit real *8(a-h, o-z)
1617  character iitime*30
1618  integer *8 inttim
1619 
1620  inttim = time8()
1621  iitime = ctime(inttim)
1622  return
1623  end subroutine mytime
1624  ! *******************************************************************
1625  ! SUBROUTINE rmami
1626  ! activate the time of flight for bunchers, cavities and accelerating
1627  ! gaps
1628  ! - indic and icor:integer flags
1629  ! - itvol and imamin: logical flags
1630  ! - itvol = true => the time of flight is activated, otherwise
1631  ! - itvol = false => the time of flight is passive
1632  ! - imamin = true => adjustments are automatically made on the phase
1633  ! of bunchers, cavities and acc. gaps
1634  ! - imamin = false => no adjustments on the phase of accelerating
1635  ! elements
1636  ! - indic = 0 => itvol = true, in this case the time of flight is
1637  ! activited for accelerating elements
1638  ! - indic (<>) 0 => itvol = false and imamin = false
1639  ! - icor = 0 => imamin = false
1640  ! - icor (<>) 0 => imamin = true
1641  ! *******************************************************************
1642  subroutine rmami
1643  implicit real *8(a-h, o-z)
1644  parameter(maxcell1=3000)
1645  common /tapes/in, ifile, meta
1646  common /dyn/tref, vref
1647  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1648  common /consta/vl, pi, xmat, rpel, qst
1649  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
1650  common /itvole/itvol, imamin
1651  common /tofev/ttvols
1652  logical itvol, imamin
1653 
1654  fcpi = fh*180./pi
1655  ttvols = 0.
1656  read (in, *) indic, icor
1657  if (indic==0) then
1658  itvol = .true.
1659  ttvols = tref
1660  write (16, 10) ttvols*fcpi, davtot, tref*fcpi
1661  else
1662  itvol = .false.
1663  write (16, *) 'time of flight passive '
1664  end if
1665 10 format (' ** time of flight activated at: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
1666  'tof of the reference: ', e12.5, ' deg')
1667  imamin = .false.
1668  if (itvol .and. icor/=0) imamin = .true.
1669  if (imamin) write (16, *) ' Adjustments on phase offset of acc. elements'
1670  if (.not. imamin) write (16, *) ' No adjustments on phase offset'
1671  return
1672  end subroutine rmami
1673  ! *******************************************************************
1674  ! SUBROUTINE kick
1675  ! 2015 now obsolete (?) see subroutine aliner
1676  ! *******************************************************************
1677  ! SUBROUTINE kick
1678  ! implicit real*8 (a-h,o-z)
1679  ! C ..................................
1680  ! C ALIGNMENT DEFAULTS :
1681  ! C HORIZONTAL : XL(cm)
1682  ! C VERTICAL : YL(cm)
1683  ! C ..................................
1684  ! parameter (iptsz=100002,maxcell=3000,maxcell1=3000)
1685  ! COMMON/DESA/XL,YL,IFLAG
1686  ! common/faisc/f(10,iptsz),imax,ngood
1687  ! WRITE(16,100) XL,YL
1688  ! 100 FORMAT(/,5X,' KICK x(cm) y(cm): ',2(e12.5,2x),/)
1689  ! C CM-MRD
1690  ! DO II=1,ngood
1691  ! if(iflag.ne.1) then
1692  ! F(2,II)=F(2,II) + XL
1693  ! F(4,II)=F(4,II) + YL
1694  ! else
1695  ! C F(2,II)=F(2,II) - XL
1696  ! F(4,II)=F(4,II) - YL
1697  ! endif
1698  ! enddo
1699  ! RETURN
1700  ! END
1701  ! *******************************************************************
1702  ! SUBROUTINE shuffle
1703  ! Reshuffles f(i,j) array so that the "good" particles are on top of
1704  ! the stack. The number of "good" particles (ngood) is passed back.
1705  ! *******************************************************************
1706  subroutine shuffle
1707  implicit real *8(a-h, o-z)
1708  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
1709  common /faisc/f(10, iptsz), imax, ngood
1710  common /mcs/imcs, ncstat, cstat(20)
1711  common /macro/ratei
1712 
1713  k = ngood
1714  ngood1 = 0
1715 1 if (ngood1>=k) go to 5
1716  if (f(8,ngood1+1)==1.) go to 4
1717  do j = 1, 10
1718  c = f(j, ngood1+1)
1719  f(j, ngood1+1) = f(j, k)
1720  f(j, k) = c
1721  end do
1722  k = k - 1
1723  go to 1
1724 4 ngood1 = ngood1 + 1
1725  go to 1
1726 5 continue
1727  ngood = ngood1
1728  if (ngood==0) then
1729  ratei = 0.
1730  else
1731  ratei = float(imax)/float(ngood)
1732  end if
1733  ! *ets*2015/05/20
1734  ncstat = 1
1735  cstat(1) = f(9, 1)
1736  do j = 2, ngood
1737  mcstat = 0
1738  do k = 1, ncstat
1739  if (f(9,j)==cstat(k)) then
1740  mcstat = 1
1741  end if
1742  end do
1743  if (mcstat==0) then
1744  ncstat = ncstat + 1
1745  cstat(ncstat) = f(9, j)
1746  end if
1747  end do
1748  write (16, *) 'Number of charge states after shuffle: ', ncstat
1749  write (16, *) 'Charge states: ', (cstat(j), j=1, ncstat)
1750  imcs = 0
1751  if (ncstat>1) imcs = 1
1752  ! *ete*2015/05/20
1753  ! omment write(16,*) '***reshuffle: ',ngood,' good particles'
1754  if (ngood<10) then
1755  write (16, *) 'Less than 10 particles left, statistics too low'
1756  write (6, *)
1757  write (6, *) 'Less than 10 particles left, statistics too low'
1758  stop
1759  end if
1760  return
1761  end subroutine shuffle
1762  ! *******************************************************************
1763  ! FUNCTION xitl0(GAMI,GAMS,BETR,SAPHI,QQC)
1764  ! called by RESTAY and ETGAP dynamics computations
1765  ! *******************************************************************
1766  function xitl0(gami, gams, betr, saphi, qqc)
1767  implicit real *8(a-h, o-z)
1768  common /consta/vl, pi, xmat, rpel, qst
1769  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1770  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1771 
1772  fh0 = fh/vl
1773  cgi = qqc/xmat
1774  beti = sqrt(1.-1./(gami*gami))
1775  bets = sqrt(1.-1./(gams*gams))
1776  xk1 = fh0/beti
1777  xk2 = fh0/bets
1778  xkm = fh0/betr
1779  tilta2 = phslip/(2.*eqvl)
1780  pavph = 1./10.*(xk1-xk2)*eqvl + (xk1-xkm)*asdl
1781  xkc1 = -fh0/(beti**3*gami**3)
1782  xkc2 = -fh0/(bets**3*gams**3)
1783  do i = 1, 2
1784  phit10 = saphi - phslip/2. + pavph
1785  daz0 = cos(phit10)*tilta2
1786  dbz0 = sin(phit10)*tilta2
1787  dgz0 = cgi*(tk*daz0-sk*dbz0)
1788  dgz0 = dgz0/sin(phslip/2.)
1789  xkp1 = xkc1*dgz0
1790  phit11 = saphi + phslip/2. + pavph
1791  daz1 = cos(phit11)*tilta2
1792  dbz1 = sin(phit11)*tilta2
1793  dgz1 = cgi*(tk*daz1-sk*dbz1)
1794  dgz1 = dgz1/sin(phslip/2.)
1795  xkp2 = xkc2*dgz1
1796  pavph = 1./10.*(xk1-xk2)*eqvl + (xk1-xkm)*asdl
1797  pavph = pavph + (xkp1+xkp2)*eqvl**2/120.
1798  end do
1799  xk11 = xk1 - xkm
1800  xk22 = xk2 - xkm
1801  aa = xk11
1802  bb = xkp1/2.
1803  ccl1 = -(4.*xk22+6.*xk11)/(eqvl**2)
1804  ccl2 = -(3./2.*xkp1-xkp2/2.)/eqvl
1805  cc = ccl1 + ccl2
1806  ddl1 = (7.*xk22+8.*xk11)/(eqvl**3)
1807  ddl2 = (3./2.*xkp1-xkp2)/(eqvl**2)
1808  dd = ddl1 + ddl2
1809  eel1 = -(3.*xk22+3.*xk11)/(eqvl**4)
1810  eel2 = -(xkp1/2.-xkp2/2.)/(eqvl**3)
1811  ee = eel1 + eel2
1812  phit0 = saphi + pavph
1813  git = cgi*(tk*cos(phit0)-sk*sin(phit0))
1814  xitl0 = gami + git
1815  return
1816  end function xitl0
1817  ! *******************************************************************
1818  ! FUNCTION xitl2(GAMI,GAMS,BETR,SAPHI,QQC)
1819  ! called by RESTAY and ETGAP
1820  ! INTEGRAL of S ( EZG * Z/(BETA*GAMA)**3 *DZ)
1821  ! PHASE JUMP
1822  ! *******************************************************************
1823  function xitl2(gami, gams, betr, saphi, qqc)
1824  implicit real *8(a-h, o-z)
1825  common /consta/vl, pi, xmat, rpel, qst
1826  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1827  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1828  dimension h(8), t(8)
1829  data h/.101228536, .222381034, .313706646, .362683783, .362683783, .313706646, .222381034, .101228536/
1830  data t/ -.960289856, -.796666477, -.525532409, -.183434642, .183434642, .525532409, .796666477, .960289856/
1831 
1832  fh0 = fh/vl
1833  cgi = qqc/xmat
1834  xitl2 = 0.
1835  beti = sqrt(1.-1./(gami*gami))
1836  bets = sqrt(1.-1./(gams*gams))
1837  xk1 = fh0/beti
1838  xk2 = fh0/bets
1839  xkm = fh0/betr
1840  tilta2 = phslip/(2.*eqvl)
1841  do i = 1, 8
1842  xcc = eqvl*(1.+t(i))/2.
1843  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
1844  git = cgi*(tk*cos(phit0)-sk*sin(phit0))
1845  gi = gami + git*sin(xcc*tilta2)/sin(phslip/2.)
1846  bi = sqrt(1.-1./(gi*gi))
1847  phit1 = phit0 + xcc*phslip/(2.*eqvl)
1848  daz = cos(phit1)*tilta2
1849  dbz = sin(phit1)*tilta2
1850  dgz = cgi*(tk*daz-sk*dbz)
1851  dgz = dgz/sin(phslip/2.)
1852  ez = xmat/qqc*dgz
1853  xint = 1./(bi*gi)
1854  xcc1 = xcc + asdl
1855  xitl2 = xitl2 + h(i)*xint**3*xcc1*ez
1856  end do
1857  xitl2 = xitl2/2.*eqvl
1858  return
1859  end function xitl2
1860  ! *******************************************************************
1861  ! FUNCTION xitl3(GAMI,GAMS,BETR,NIT,SAPHI,QQC)
1862  ! called by RESTAY and ETGAP
1863  ! INTEGRAL S ( EZG * Z/(BETA*GAMA)**3 *DZ)
1864  ! PHASE AND ENERGY AT THE MIDDLE OF THE GAP
1865  ! *******************************************************************
1866  function xitl3(gami, gams, betr, nit, saphi, qqc)
1867  implicit real *8(a-h, o-z)
1868  common /consta/vl, pi, xmat, rpel, qst
1869  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1870  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1871  common /midgap/enmil, vapmi
1872  common /gaus13/h(13), t(13)
1873  common /sgcos/xkpc
1874 
1875  fh0 = fh/vl
1876  cgi = qqc/xmat
1877  xitl3 = 0.
1878  beti = sqrt(1.-1./(gami*gami))
1879  bets = sqrt(1.-1./(gams*gams))
1880  xk1 = fh0/beti
1881  xk2 = fh0/bets
1882  xkm = fh0/betr
1883  xk11 = xk1 - xkm
1884  tilta2 = phslip/(2.*eqvl)
1885  do i = 1, 13
1886  xcc = eqvl*(1.+t(i))/2.
1887  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
1888  git = cgi*(tk*cos(phit0)-sk*sin(phit0))
1889  gi = gami + git*sin(xcc*tilta2)/sin(phslip/2.)
1890  bi = sqrt(1.-1./(gi*gi))
1891  phit1 = phit0 + xcc*phslip/(2.*eqvl)
1892  daz = cos(phit1)*tilta2
1893  dbz = sin(phit1)*tilta2
1894  dgz = cgi*(tk*daz-sk*dbz)
1895  dgz = dgz/sin(phslip/2.)
1896  ez = xmat/qqc*dgz
1897  xint = 1./(bi*gi)
1898  xcc1 = xcc + asdl
1899  xitl3 = xitl3 + h(i)*xint**3*xcc1*ez
1900  ! ENERGY AND PHASE AT THE MIDDLE OF THE GAP
1901  if (nit==3 .and. i==7) then
1902  ! ENMIL=XMAT*(GI-GAMI)
1903  enmil = xmat*(gi-1.)
1904  vapmi = (xk11*asdl+saphi+xkm*xcc1+aa*xcc+bb*xcc*xcc+cc*xcc**3+dd*xcc**4+ee*xcc**5)*180./pi
1905  end if
1906  end do
1907  xitl3 = xitl3/2.*eqvl
1908  return
1909  end function xitl3
1910  ! *******************************************************************
1911  ! SUBROUTINE xtypl2(GAMI,SAPHI,QSC,DCG)
1912  ! called by RESTAY and ETGAP
1913  ! integrals of the second derivative of the functions HA0(z) and HB0(z)
1914  ! ZB = Z+ASDL
1915  ! *******************************************************************
1916  subroutine xtypl2(gami, saphi, qsc, dcg)
1917  implicit real *8(a-h, o-z)
1918  common /consta/vl, pi, xmat, rpel, qst
1919  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
1920  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
1921  common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
1922  common /gaus17/h1(17), t1(17)
1923 
1924  fh0 = fh/vl
1925  cgi = qsc/xmat
1926  gam2 = gami**2
1927  beti = sqrt(1.-1./gam2)
1928  xk1 = fh0/beti
1929  ! circular functions in cos
1930  h0aki = 0.
1931  h0akim = 0.
1932  h0akm = 0.
1933  h1aki = 0.
1934  h1akim = 0.
1935  h1akm = 0.
1936  ! circular functions in sin
1937  h0bki = 0.
1938  h0bkim = 0.
1939  h0bkm = 0.
1940  h1bki = 0.
1941  h1bkim = 0.
1942  h1bkm = 0.
1943 
1944  dtilk = eqvl
1945  tilta2 = phslip/(2.*eqvl)
1946  cgam10 = ((gami*gami-1.)**3)/(fh0*fh0)
1947  dgam10 = gami*((gami*gami-1.)**2)/(fh0*fh0)
1948  phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
1949  dphc1 = (t2k*sk-s2k*tk)/(tk*tk+sk*sk)
1950  dphc2 = (t1k*tk+s1k*sk)*(t1k*sk-s1k*tk)/((tk*tk+sk*sk)**2)
1951  dphcrtk = dphc1 - 2.*dphc2
1952  bim1 = beti
1953  gakm1 = 0.
1954  gait = gami
1955  do i = 1, 17
1956  xcc = eqvl*(1.+h1(i))/2.
1957  xcc1 = xcc + asdl
1958  if (xcc1>dcg) go to 200
1959  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
1960  ! Function GAMMA (Z)
1961  if (phslip/=0.) then
1962  git = cgi*sqcttf*cos(phit0-pcrest)/phslip
1963  gis = sin(xcc*tilta2)
1964  else
1965  git = cgi*sqcttf*cos(phit0-pcrest)
1966  gis = xcc/(2.*eqvl)
1967  end if
1968  gitc = git*gis
1969  gi = gami + git*gis
1970  bi = sqrt(1.-1./(gi*gi))
1971  ! FONCTION DERIVE G0(Z) RELATIF A K MOYEN
1972  phit0k = -dtilk*(1.-xcc/eqvl)/2.
1973  ! DERIVE PREMIERE FONGTION GAMMA
1974  if (phslip/=0.) then
1975  gic = cos(xcc*tilta2)
1976  gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
1977  gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
1978  gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
1979  gak = cgi*sqcttf*(-gak1-gak2+gak3)
1980  else
1981  gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
1982  gak = -cgi*sqcttf*gak1
1983  end if
1984  ! Second derivative of GAMMA(z)
1985  if (gi/=gait) then
1986  dgak = (gak-gakm1)/(gi-gait)*gak
1987  else
1988  dgak = 0.
1989  end if
1990  gakm1 = gak
1991  gait = gi
1992  xcc1 = xcc + asdl
1993  phit1 = phit0 + xcc*phslip/(2.*eqvl)
1994  phtz0 = (xcc/eqvl-.5)*dtilk
1995  dphtz0 = dtilk/eqvl
1996  phcrz0 = (phtz0-phcrtk)
1997  ! INTEGRALES FONCTIONS HAKI(Z) (a multipler par (k1i-k10)**2 )
1998  haki1 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**2.5)
1999  haki2 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2000  haki3 = sqcttf*cos(phit1-pcrest)*gi*gi/((gi*gi-1.)**3.5)
2001  ! n=0
2002  h0aki = h0aki + t1(i)*cgam10*(-3.*haki1+15*haki3) - t1(i)*dgam10*9.*haki2
2003  ! n=1
2004  h1aki = h1aki + t1(i)*cgam10*xcc1*(-3.*haki1+15.*haki3) - t1(i)*dgam10*9.*haki2*xcc1
2005  ! Integral of HAKIM(Z) (to be multiplied by (k1i-k10)*(kmi-km0) )
2006  hakim1 = sqcttf*cos(phit1-pcrest)*gak/((gi*gi-1.)**2.5)
2007  hakim2 = sqcttf*cos(phit1-pcrest)*gi*gi*gak/((gi*gi-1.)**3.5)
2008  hakim2 = hakim2
2009  hakim3 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2010  ! n=0
2011  h0akim = h0akim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2-3.*phcrz0*hakim3)
2012  ! n=1
2013  h1akim = h1akim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2-3.*phcrz0*hakim3)*xcc1
2014  ! Integral of HAKM(Z) (to be multiplied by (kmi-km0)**2 )
2015  hakm1 = sqcttf*cos(phit1-pcrest)*gak*gak/((gi*gi-1.)**2.5)
2016  hakm2 = sqcttf*cos(phit1-pcrest)*dgak*gi/((gi*gi-1.)**2.5)
2017  hakm3 = sqcttf*cos(phit1-pcrest)*gak*gak*gi*gi/((gi*gi-1.)**3.5)
2018  hakm4 = sqcttf*sin(phit1-pcrest)*gak*gi/((gi*gi-1.)**2.5)
2019  hakm5 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
2020  hakm6 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
2021  ! n=0
2022  h0akm = h0akm + t1(i)*(-3.*hakm1-3.*hakm2+15.*hakm3+3.*phcrz0*hakm4-phcrz0*phcrz0*hakm5+dphcrtk*hakm6)
2023  ! n=1
2024  h1akm = h1akm + t1(i)*xcc1*(-3.*hakm1-3.*hakm2+15.*hakm3+3.*phcrz0*hakm4-phcrz0*phcrz0*hakm5+dphcrtk*hakm6)
2025 
2026  ! INTEGRALES FONCTIONS HBKI(Z) (a multipler par (k1i-k10)**2 )
2027  hbki1 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**2.5)
2028  hbki2 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2029  hbki3 = sqcttf*sin(phit1-pcrest)*gi*gi/((gi*gi-1.)**3.5)
2030  ! n=0
2031  h0bki = h0bki + t1(i)*cgam10*(-3.*hbki1+15.*hbki3) - t1(i)*dgam10*9.*hbki2
2032  ! n=1
2033  h1bki = h1bki + t1(i)*cgam10*xcc1*(-3.*hbki1+15.*hbki3) - t1(i)*dgam10*9.*hbki2*xcc1
2034  ! Integral of HBKIM(Z) (to be multiplied by (k1i-k10)*(kmi-km0) )
2035  hbkim1 = sqcttf*sin(phit1-pcrest)*gak/((gi*gi-1.)**2.5)
2036  hbkim2 = sqcttf*sin(phit1-pcrest)*gi*gi*gak/((gi*gi-1.)**3.5)
2037  hbkim2 = hbkim2
2038  hbkim3 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
2039  ! n=0
2040  h0bkim = h0bkim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2+3.*phcrz0*hakim3)
2041  ! n=1
2042  h1bkim = h1bkim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2+3.*phcrz0*hakim3)*xcc1
2043  ! Integral of HBKM(Z) (to be multiplied by (kmi-km0)**2 )
2044  hbkm1 = sqcttf*sin(phit1-pcrest)*gak*gak/((gi*gi-1.)**2.5)
2045  hbkm2 = sqcttf*sin(phit1-pcrest)*dgak*gi/((gi*gi-1.)**2.5)
2046  hbkm3 = sqcttf*sin(phit1-pcrest)*gak*gak*gi*gi/((gi*gi-1.)**3.5)
2047  hbkm4 = sqcttf*cos(phit1-pcrest)*gak*gi/((gi*gi-1.)**2.5)
2048  hbkm5 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
2049  hbkm6 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
2050  ! n=0
2051  h0bkm = h0bkm + t1(i)*(-3.*hbkm1-3.*hbkm2+15.*hbkm3-3.*phcrz0*hbkm4-phcrz0*phcrz0*hbkm5-dphcrtk*hbkm6)
2052  ! n=1
2053  h1bkm = h1bkm + t1(i)*xcc1*(-3.*hbkm1-3.*hbkm2+15.*hbkm3-3.*phcrz0*hbkm4-phcrz0*phcrz0*hbkm5-dphcrtk*hbkm6)
2054  end do
2055 200 continue
2056  ! integrals in cos
2057  h0aki = h0aki/2.*eqvl
2058  h0akim = h0akim/2.*eqvl
2059  h0akm = h0akm/2.*eqvl
2060  h1aki = h1aki/2.*eqvl
2061  h1akim = h1akim/2.*eqvl
2062  h1akm = h1akm/2.*eqvl
2063  ! integrals in sin
2064  h0bki = h0bki/2.*eqvl
2065  h0bkim = h0bkim/2.*eqvl
2066  h0bkm = h0bkm/2.*eqvl
2067  h1bki = h1bki/2.*eqvl
2068  h1bkim = h1bkim/2.*eqvl
2069  h1bkm = h1bkm/2.*eqvl
2070  return
2071  end subroutine xtypl2
2072  ! *******************************************************************
2073  ! SUBROUTINE xtyplp1(GAMI,SAPHI,QSC,DCG)
2074  ! called by RESTAY and ETGAP
2075  ! Integrals of functions HA0(Z) and HB0(Z)
2076  ! Integrals of the first and second derivative of HA0(Z) et HB0(Z)(with PH01)
2077  ! Integrals of the third derivative of HA0(Z) et HB0(Z)(with PH01)
2078  ! zb = z+ASDL
2079  ! *******************************************************************
2080  subroutine xtyplp1(gami, saphi, qsc, dcg)
2081  implicit real *8(a-h, o-z)
2082  common /consta/vl, pi, xmat, rpel, qst
2083  common /jacob/gaks, gaps
2084  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2085  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2086  common /typlp1/yh1p1, yh2p1, hapi, hbpi
2087  common /typlp2/happi, hbppi
2088  common /gaus17/h1(17), t1(17)
2089 
2090  fh0 = fh/vl
2091  cgi = qsc/xmat
2092  gam2 = gami**2
2093  beti = sqrt(1.-1./gam2)
2094  xk1 = fh0/beti
2095  dtilk = eqvl
2096  ! circular functions in cos
2097  yh1p1 = 0.
2098  hapi = 0.
2099  happi = 0.
2100  ! circular functions in sin
2101  yh2p1 = 0.
2102  hbpi = 0.
2103  hbppi = 0.
2104  tilta2 = phslip/(2.*eqvl)
2105  if (phslip/=0.) desy = phslip/sin(phslip/2.)
2106  if (phslip==0.) desy = 2.
2107  do i = 1, 17
2108  xcc = eqvl*(1.+h1(i))/2.
2109  xcc1 = xcc + asdl
2110  if (xcc1>dcg) go to 200
2111  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2112  ! FONCTION GAMMA (Z)
2113  if (phslip/=0.) then
2114  git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2115  gis = sin(xcc*tilta2)
2116  else
2117  git = cgi*sqcttf*cos(phit0-pcrest)
2118  gis = xcc/(2.*eqvl)
2119  end if
2120  gi = gami + git*gis
2121  bi = sqrt(1.-1./(gi*gi))
2122  ! FONCTION DERIVE G0(Z) RELATIF A PH01
2123  if (phslip/=0.) then
2124  gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2125  ! DERIVE TROISIEME
2126  ddgap = -gap
2127  else
2128  gap = sin(phit0-pcrest)*gis
2129  gap = -cgi*sqcttf*gap
2130  ddgap = -gap
2131  end if
2132  if (i==17) gaps = gap
2133  ! Second derivative of G0(Z) in relation with PH01
2134  if (phslip/=0.) then
2135  dgap = -cgi*sqcttf*cos(phit0-pcrest)*gis/phslip
2136  else
2137  dgap = cos(phit0-pcrest)*gis
2138  dgap = -cgi*sqcttf*dgap
2139  end if
2140  ! INTEGRALES FONCTIONS HA0(Z) et HB0(Z)
2141  xint = 1./(bi*bi*bi*gi*gi*gi)
2142  phit1 = phit0 + xcc*phslip/(2.*eqvl)
2143  phtz0 = (xcc/eqvl-.5)*dtilk
2144  ! INTEGRALES DERIVES HA0(Z)
2145  dha01 = sqcttf*cos(phit1-pcrest)*gi*gap/((gi*gi-1.)**2.5)
2146  dha02 = 0.
2147  ! n=1
2148  yh1p1 = yh1p1 + t1(i)*xcc1*(-6.*dha01-2.*dha02)
2149  ! INTEGRALES DERIVES HB0(Z)
2150  dhb01 = sqcttf*sin(phit1-pcrest)*gi*gap/((gi*gi-1.)**2.5)
2151  dhb02 = 0.
2152  ! n=1
2153  yh2p1 = yh2p1 + t1(i)*xcc1*(-6.*dhb01+2.*dhb02)
2154  ! INTEGRALES HAPI(Z) (multiplies par (ph1i-ph10)**2 )
2155  hapi1 = sqcttf*cos(phit1-pcrest)*gap*gap/((gi*gi-1.)**2.5)
2156  hapi2 = sqcttf*cos(phit1-pcrest)*gi*dgap/((gi*gi-1.)**2.5)
2157  hapi3 = sqcttf*cos(phit1-pcrest)*gi*gi*gap*gap/((gi*gi-1.)**3.5)
2158  ! n=1
2159  hapi = hapi + t1(i)*xcc1*(-3.*hapi1-3.*hapi2+15.*hapi3)
2160  ! INTEGRALES HAPPI(Z) (multiplies par (ph1i-ph10)**3 )/3
2161  happi1 = sqcttf*cos(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
2162  happi2 = sqcttf*cos(phit1-pcrest)*gap*gap*gap*gi/((gi*gi-1.)**3.5)
2163  happi3 = sqcttf*cos(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
2164  happi4 = sqcttf*cos(phit1-pcrest)*gi*ddgap/((gi*gi-1.)**2.5)
2165  happi5 = sqcttf*cos(phit1-pcrest)*gi*gi*gap*dgap/((gi*gi-1.)**3.5)
2166  happi6 = sqcttf*cos(phit1-pcrest)*gi*gap**3/((gi*gi-1.)**3.5)
2167  happi7 = sqcttf*cos(phit1-pcrest)*gi*gi*dgap*gap/((gi*gi-1.)**3.5)
2168  happi8 = sqcttf*cos(phit1-pcrest)*gi*gi*gi*gap*gap*gap/((gi*gi-1.)**4.5)
2169  ! n=1
2170  happi = happi + t1(i)*xcc1*(-6.*happi1+15.*happi2-3.*happi3-3.*happi4+15.*happi5+30.*happi6+30.*happi7-105.* &
2171  happi8)
2172 
2173  ! INTEGRAL OF HBPI(Z) (to be multiplied by (ph1i-ph10)**2 )
2174  hbpi1 = sqcttf*sin(phit1-pcrest)*gap*gap/((gi*gi-1.)**2.5)
2175  hbpi2 = sqcttf*sin(phit1-pcrest)*gi*dgap/((gi*gi-1.)**2.5)
2176  hbpi3 = sqcttf*sin(phit1-pcrest)*gi*gi*gap*gap/((gi*gi-1.)**3.5)
2177  ! n=1
2178  hbpi = hbpi + t1(i)*xcc1*(-3.*hbpi1-3.*hbpi2+15.*hbpi3)
2179  ! INTEGRALS of HBPPI(Z) (to be multiplied by(ph1i-ph10)**3 )/3
2180  hbppi1 = sqcttf*sin(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
2181  hbppi2 = sqcttf*sin(phit1-pcrest)*gap*gap*gap*gi/((gi*gi-1.)**3.5)
2182  hbppi3 = sqcttf*sin(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
2183  hbppi4 = sqcttf*sin(phit1-pcrest)*gi*ddgap/((gi*gi-1.)**2.5)
2184  hbppi5 = sqcttf*sin(phit1-pcrest)*gi*gi*gap*dgap/((gi*gi-1.)**3.5)
2185  hbppi6 = sqcttf*sin(phit1-pcrest)*gi*gap**3/((gi*gi-1.)**3.5)
2186  hbppi7 = sqcttf*sin(phit1-pcrest)*gi*gi*dgap*gap/((gi*gi-1.)**3.5)
2187  hbppi8 = sqcttf*sin(phit1-pcrest)*gi*gi*gi*gap*gap*gap/((gi*gi-1.)**4.5)
2188  ! n=1
2189  hbppi = happi + t1(i)*xcc1*(-6.*hbppi1+15.*hbppi2-3.*hbppi3-3.*hbppi4+15.*hbppi5+30.*hbppi6+30.*hbppi7-105.* &
2190  hbppi8)
2191  end do
2192 200 continue
2193  ! INTEGRALS to be multiplied by cos
2194  yh1p1 = yh1p1/2.*eqvl
2195  hapi = hapi/2.*eqvl
2196  happi = happi/2.*eqvl
2197  ! INTEGRALS to be multiplied by sin
2198  yh2p1 = yh2p1/2.*eqvl
2199  hbpi = hbpi/2.*eqvl
2200  hbppi = hbppi/2.*eqvl
2201  return
2202  end subroutine xtyplp1
2203  ! *******************************************************************
2204  ! SUBROUTINE xtylpk(GAMI,SAPHI,QSC,DCG)
2205  ! called by RESTAY and ETGAP
2206  ! INTEGRALS of HA0(Z) and HB0(Z)
2207  ! INTEGRALS of the second derivative of HA0(Z) and HB0(Z)
2208  ! zb = z+ASDL
2209  ! *******************************************************************
2210  subroutine xtylpk(gami, saphi, qsc, dcg)
2211  implicit real *8(a-h, o-z)
2212  common /consta/vl, pi, xmat, rpel, qst
2213  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2214  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2215  common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
2216  common /gaus17/h1(17), t1(17)
2217 
2218  fh0 = fh/vl
2219  cgi = qsc/xmat
2220  gam2 = gami**2
2221  beti = sqrt(1.-1./gam2)
2222  xk1 = fh0/beti
2223  dtilk = eqvl
2224  ! CIRCULAIRES EN COS
2225  yh10pk = 0.
2226  yh11pk = 0.
2227  ! CIRCULAIRES EN SIN
2228  yh20pk = 0.
2229  yh21pk = 0.
2230  tilta2 = phslip/(2.*eqvl)
2231  if (phslip/=0.) desy = phslip/sin(phslip/2.)
2232  if (phslip==0.) desy = 2.
2233  cgam10 = ((gami*gami-1.)**1.5)/fh0
2234  phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
2235  do i = 1, 17
2236  xcc = eqvl*(1.+h1(i))/2.
2237  xcc1 = xcc + asdl
2238  if (xcc1>dcg) go to 200
2239  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2240  ! FONCTION GAMMA (Z)
2241  if (phslip/=0.) then
2242  git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2243  gis = sin(xcc*tilta2)
2244  else
2245  git = cgi*sqcttf*cos(phit0-pcrest)
2246  gis = xcc/(2.*eqvl)
2247  end if
2248  gi = gami + git*gis
2249  bi = sqrt(1.-1./(gi*gi))
2250  ! Derivative of G0(Z) in relation with: PH01
2251  if (phslip/=0.) then
2252  gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2253  else
2254  gap = sin(phit0-pcrest)*gis
2255  gap = -cgi*sqcttf*gap
2256  end if
2257  ! Derivative of G0(Z) in relation with the equivalent K
2258  phit0k = -dtilk*(1.-xcc/eqvl)/2.
2259  if (phslip/=0.) then
2260  gic = cos(xcc*tilta2)
2261  gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
2262  gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2263  gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2264  gak = cgi*sqcttf*(-gak1-gak2+gak3)
2265  else
2266  gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
2267  gak = -cgi*sqcttf*gak1
2268  end if
2269  ! derivative of G0(Z) in relation with the equivalent k and the phase PHI
2270  if (phslip/=0.) then
2271  gic = cos(xcc*tilta2)
2272  gakp1 = dtilk*sin(phit0-pcrest)*gis/(phslip*phslip)
2273  gakp2 = cos(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2274  gakp3 = dtilk*sin(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2275  gakp = cgi*sqcttf*(gakp1-gakp2-gakp3)
2276  else
2277  gakp1 = cos(phit0-pcrest)*gis*(phit0k-phcrtk)
2278  gakp = -cgi*sqcttf*gakp1
2279  end if
2280  ! INTEGRALS of HA0(Z) and HB0(Z)
2281  xint = 1./(bi*bi*bi*gi*gi*gi)
2282  phit1 = phit0 + xcc*phslip/(2.*eqvl)
2283  ! INTEGRALES DERIVE HA0(Z) HB0(Z) k0 ET PHI
2284  dha01 = sqcttf*cos(phit1-pcrest)*gap/((gi*gi-1.)**2.5)
2285  dha02 = sqcttf*cos(phit1-pcrest)*gi*gi*gap/((gi*gi-1.)**3.5)
2286  dhb01 = sqcttf*sin(phit1-pcrest)*gap/((gi*gi-1.)**2.5)
2287  dhb02 = sqcttf*sin(phit1-pcrest)*gi*gi*gap/((gi*gi-1.)**3.5)
2288  ! n=1
2289  yh10pk = yh10pk + t1(i)*xcc1*cgam10*(3.*dha01-15.*dha02)
2290  yh20pk = yh20pk + t1(i)*xcc1*cgam10*(3.*dhb01-15.*dhb02)
2291  ! Integrals of HA(Z) (multiplied by (ph1i-ph10)*(kmi-km0)
2292  hapi1 = sqcttf*cos(phit1-pcrest)*gap*gak/((gi*gi-1.)**2.5)
2293  hapi2 = sqcttf*cos(phit1-pcrest)*gi*gakp/((gi*gi-1.)**2.5)
2294  hapi3 = sqcttf*cos(phit1-pcrest)*gi*gi*gap*gak/((gi*gi-1.)**3.5)
2295  ! n=1
2296  yh11pk = yh11pk + t1(i)*xcc1*(-3.*hapi1-3.*hapi2+15.*hapi3)
2297  ! Integrals of HB(Z) (multiplied by (ph1i-ph10)*(kmi-km0)
2298  hbpi1 = sqcttf*sin(phit1-pcrest)*gap*gak/((gi*gi-1.)**2.5)
2299  hbpi2 = sqcttf*sin(phit1-pcrest)*gi*gakp/((gi*gi-1.)**2.5)
2300  hbpi3 = sqcttf*sin(phit1-pcrest)*gi*gi*gap*gak/((gi*gi-1.)**3.5)
2301  ! n=1
2302  yh21pk = yh21pk + t1(i)*xcc1*(-3.*hbpi1-3.*hbpi2+15.*hbpi3)
2303  end do
2304 200 continue
2305  ! Cosinus integrals
2306  yh10pk = yh10pk/2.*eqvl
2307  yh11pk = yh11pk/2.*eqvl
2308  ! Sinus integrals
2309  yh20pk = yh20pk/2.*eqvl
2310  yh21pk = yh21pk/2.*eqvl
2311  return
2312  end subroutine xtylpk
2313  ! *******************************************************************
2314  ! SUBROUTINE xtypj(GAMI,SAPHI,QSC,DCG)
2315  ! called by RESTAY and ETGAP
2316  ! INTEGRALS of g(G)*Ez(**2) *z**n n=0,1,2
2317  ! *******************************************************************
2318  subroutine xtypj(gami, saphi, qsc, dcg)
2319  implicit real *8(a-h, o-z)
2320  common /consta/vl, pi, xmat, rpel, qst
2321  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2322  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2323  common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
2324  yfscp1, yfscp2, yfs0, yfs1, yfs2
2325  common /gaus17/h1(17), t1(17)
2326 
2327  fh0 = fh/vl
2328  cgi = qsc/xmat
2329  gam2 = gami**2
2330  beti = sqrt(1.-1./gam2)
2331  xk1 = fh0/beti
2332  dtilk = eqvl
2333  yfs0 = 0.
2334  yfs1 = 0.
2335  yfs2 = 0.
2336  yfskc0 = 0.
2337  yfskc1 = 0.
2338  yfskc2 = 0.
2339  yfsk0 = 0.
2340  yfsk1 = 0.
2341  yfsk2 = 0.
2342  yfsck0 = 0.
2343  yfsck1 = 0.
2344  yfsck2 = 0.
2345  yfscp0 = 0.
2346  yfscp1 = 0.
2347  yfscp2 = 0.
2348  yfsp0 = 0.
2349  yfsp1 = 0.
2350  yfsp2 = 0.
2351  tilta2 = phslip/(2.*eqvl)
2352  if (phslip/=0.) desy = phslip/sin(phslip/2.)
2353  if (phslip==0.) desy = 2.
2354  cgam10 = ((gami*gami-1.)**1.5)/fh0
2355  phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
2356  do i = 1, 17
2357  xcc = eqvl*(1.+h1(i))/2.
2358  xcc1 = xcc + asdl
2359  if (xcc1>dcg) go to 200
2360  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2361  ! Function GAMMA (Z)
2362  if (phslip/=0.) then
2363  git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2364  gis = sin(xcc*tilta2)
2365  else
2366  git = cgi*sqcttf*cos(phit0-pcrest)
2367  gis = xcc/(2.*eqvl)
2368  end if
2369  gi = gami + git*gis
2370  bi = sqrt(1.-1./(gi*gi))
2371  ! Derivative of G0(Z) with regard to the average k
2372  phit0k = -dtilk*(1.-xcc/eqvl)/2.
2373  if (phslip/=0.) then
2374  gic = cos(xcc*tilta2)
2375  gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
2376  gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2377  gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2378  gak = cgi*sqcttf*(-gak1-gak2+gak3)
2379  else
2380  gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
2381  gak = -cgi*sqcttf*gak1
2382  end if
2383  phit1 = phit0 + xcc*phslip/(2.*eqvl)
2384  phtz0 = (xcc/eqvl-.5)*dtilk
2385  xint = (gi*gi+2.)/((gi*gi-1.)**2)
2386  xfk1 = 2.*gi*(1.-2.*(gi*gi+2.)/(gi*gi-1.))/((gi*gi-1.)**2)
2387  ha0 = cos(phit1-pcrest)
2388  hb0 = sin(phit1-pcrest)
2389  ! n=0
2390  yfs0 = yfs0 + t1(i)*ha0*ha0*xint
2391  yfskc0 = yfskc0 - t1(i)*ha0*ha0*xfk1*cgam10
2392  yfsk0 = yfsk0 + t1(i)*ha0*ha0*xfk1*gak
2393  yfsck0 = yfsck0 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)
2394  ! n=1
2395  yfs1 = yfs1 + t1(i)*ha0*ha0*xint*xcc
2396  yfskc1 = yfskc1 - t1(i)*ha0*ha0*xfk1*cgam10*xcc
2397  yfsk1 = yfsk1 + t1(i)*ha0*ha0*xfk1*gak*xcc
2398  yfsck1 = yfsck1 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)*xcc
2399  ! n=2
2400  yfs2 = yfs2 + t1(i)*ha0*ha0*xint*xcc*xcc
2401  yfskc2 = yfskc2 - t1(i)*ha0*ha0*xfk1*cgam10*xcc*xcc
2402  yfsk2 = yfsk2 + t1(i)*ha0*ha0*xfk1*gak*xcc*xcc
2403  yfsck2 = yfsck2 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)*xcc*xcc
2404  ! Derivative of G0(Z) with regard to PH01
2405  if (phslip/=0.) then
2406  gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2407  else
2408  gap = sin(phit0-pcrest)*gis
2409  gap = -cgi*sqcttf*gap
2410  end if
2411  ! n=0
2412  yfsp0 = yfsp0 + t1(i)*xfk1*gap*ha0*ha0
2413  yfscp0 = yfscp0 - 2.*t1(i)*xint*ha0*hb0
2414  ! n=1
2415  yfsp1 = yfsp1 + t1(i)*xfk1*gap*ha0*ha0*xcc
2416  yfscp1 = yfscp1 - 2.*t1(i)*xint*ha0*hb0*xcc
2417  ! n=2
2418  yfsp2 = yfsp2 + t1(i)*xfk1*gap*ha0*ha0*xcc*xcc
2419  yfscp2 = yfscp2 - 2.*t1(i)*xint*ha0*hb0*xcc*xcc
2420  end do
2421 200 continue
2422  ! IST=IAST
2423  yfs0 = yfs0/2.*eqvl
2424  yfs1 = yfs1/2.*eqvl
2425  yfs2 = yfs2/2.*eqvl
2426  yfskc0 = yfskc0/2.*eqvl
2427  yfskc1 = yfskc1/2.*eqvl
2428  yfskc2 = yfskc2/2.*eqvl
2429  yfsk0 = yfsk0/2.*eqvl
2430  yfsk1 = yfsk1/2.*eqvl
2431  yfsk2 = yfsk2/2.*eqvl
2432  yfsck0 = yfsck0/2.*eqvl
2433  yfsck1 = yfsck1/2.*eqvl
2434  yfsck2 = yfsck2/2.*eqvl
2435  yfscp0 = yfscp0/2.*eqvl
2436  yfscp1 = yfscp1/2.*eqvl
2437  yfscp2 = yfscp2/2.*eqvl
2438  yfsp0 = yfsp0/2.*eqvl
2439  yfsp1 = yfsp1/2.*eqvl
2440  yfsp2 = yfsp2/2.*eqvl
2441  return
2442  end subroutine xtypj
2443  ! *******************************************************************
2444  ! SUBROUTINE xtypm(GAMI,SAPHI,QSC,DCG)
2445  ! called by RESTAY and ETGAP
2446  ! INTEGRALS of g(G)*z**n with n=0,1,2
2447  ! *******************************************************************
2448  subroutine xtypm(gami, saphi, qsc, dcg)
2449  implicit real *8(a-h, o-z)
2450  common /consta/vl, pi, xmat, rpel, qst
2451  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2452  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2453  common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
2454  common /gaus17/h1(17), t1(17)
2455 
2456  fh0 = fh/vl
2457  cgi = qsc/xmat
2458  dtilk = eqvl
2459  yns0 = 0.
2460  yns1 = 0.
2461  yns2 = 0.
2462  ynsk0c = 0.
2463  ynsk1c = 0.
2464  ynsk2c = 0.
2465  ynsk0 = 0.
2466  ynsk1 = 0.
2467  ynsk2 = 0.
2468  ynsp0 = 0.
2469  ynsp1 = 0.
2470  ynsp2 = 0.
2471  gam2 = gami**2
2472  beti = sqrt(1.-1./gam2)
2473  xk1 = fh0/beti
2474  tilta2 = phslip/(2.*eqvl)
2475  if (phslip/=0.) desy = phslip/sin(phslip/2.)
2476  if (phslip==0.) desy = 2.
2477  cgam10 = ((gami*gami-1.)**1.5)/fh0
2478  phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
2479  do i = 1, 17
2480  xcc = eqvl*(1.+h1(i))/2.
2481  xcc1 = xcc + asdl
2482  if (xcc1>dcg) go to 200
2483  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
2484  ! Function GAMMA (Z)
2485  if (phslip/=0.) then
2486  git = cgi*sqcttf*cos(phit0-pcrest)/phslip
2487  gis = sin(xcc*tilta2)
2488  else
2489  git = cgi*sqcttf*cos(phit0-pcrest)
2490  gis = xcc/(2.*eqvl)
2491  end if
2492  gi = gami + git*gis
2493  bi = sqrt(1.-1./(gi*gi))
2494  ! Derivative of G0(Z) with regard to the average k
2495  phit0k = -dtilk*(1.-xcc/eqvl)/2.
2496  if (phslip/=0.) then
2497  gic = cos(xcc*tilta2)
2498  gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
2499  gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
2500  gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
2501  gak = cgi*sqcttf*(-gak1-gak2+gak3)
2502  else
2503  gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
2504  gak = -cgi*sqcttf*gak1
2505  end if
2506  xint = (gi*gi+2.)/((gi*gi-1.)**2)
2507  xnk1 = 2.*gi*(1.-2.*(gi*gi+2.)/(gi*gi-1.))/((gi*gi-1.)**2)
2508  ! n=0
2509  yns0 = yns0 + t1(i)*xint
2510  ynsk0c = ynsk0c - t1(i)*xnk1*cgam10
2511  ynsk0 = ynsk0 + t1(i)*xnk1*gak
2512  ! n=1
2513  yns1 = yns1 + t1(i)*xint*xcc
2514  ynsk1c = ynsk1c - t1(i)*xnk1*cgam10*xcc
2515  ynsk1 = ynsk1 + t1(i)*xnk1*gak*xcc
2516  ! n=2
2517  yns2 = yns2 + t1(i)*xint*xcc*xcc
2518  ynsk2c = ynsk2c - t1(i)*xnk1*cgam10*xcc*xcc
2519  ynsk2 = ynsk2 + t1(i)*xnk1*gak*xcc*xcc
2520  ! DERIVE G0(Z) RELATIF A PH01
2521  if (phslip/=0.) then
2522  gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
2523  else
2524  gap = sin(phit0-pcrest)*gis
2525  gap = -cgi*sqcttf*gap
2526  end if
2527  ynsp0 = ynsp0 + t1(i)*xnk1*gap
2528  ynsp1 = ynsp1 + t1(i)*xnk1*gap*xcc
2529  ynsp2 = ynsp2 + t1(i)*xnk1*gap*xcc*xcc
2530  end do
2531 200 continue
2532  yns0 = yns0/2.*eqvl
2533  yns1 = yns1/2.*eqvl
2534  yns2 = yns2/2.*eqvl
2535  ynsk0c = ynsk0c/2.*eqvl
2536  ynsk1c = ynsk1c/2.*eqvl
2537  ynsk2c = ynsk2c/2.*eqvl
2538  ynsk0 = ynsk0/2.*eqvl
2539  ynsk1 = ynsk1/2.*eqvl
2540  ynsk2 = ynsk2/2.*eqvl
2541  ynsp0 = ynsp0/2.*eqvl
2542  ynsp1 = ynsp1/2.*eqvl
2543  ynsp2 = ynsp2/2.*eqvl
2544  return
2545  end subroutine xtypm
2546  ! *******************************************************************
2547  ! FUNCTION gamci(PHI,PCRESI,GAMI,IST,QSC)
2548  ! called by RESTAY and ETGAP
2549  ! CURRENT GAMMA VALUE (the POSITION IS GIVEN BY IST)
2550  ! *******************************************************************
2551  function gamci(phi, pcresi, gami, ist, qsc)
2552  implicit real *8(a-h, o-z)
2553  common /consta/vl, pi, xmat, rpel, qst
2554  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2555  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
2556  common /gaus17/h1(17), t1(17)
2557 
2558  gamci = 0.
2559  if (ist>17) return
2560  cgi = qsc/xmat
2561  tilta2 = phslip/(2.*eqvl)
2562  i = ist
2563  xcc = eqvl*(1.+h1(i))/2.
2564  phit0 = phi - phslip*(eqvl-xcc)/(2.*eqvl)
2565  ! Function GAMMA (Z)
2566  if (phslip/=0.) then
2567  git = cgi*sqcttf*cos(phit0-pcresi)/phslip
2568  gis = sin(xcc*tilta2)
2569  else
2570  git = cgi*sqcttf*cos(phit0-pcrest)
2571  gis = xcc/(2.*eqvl)
2572  end if
2573  gamci = gami + git*gis
2574  return
2575  end function gamci
2576  ! *******************************************************************
2577  ! SUBROUTINE intga(npt,ireca)
2578  ! Calculate the beam self fields acting on each particle (called by
2579  ! SCHERM) Gauss quadrature
2580  ! *******************************************************************
2581  subroutine intga(npt, ireca)
2582  implicit real *8(a-h, o-z)
2583  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
2584  common /consta/vl, pi, xmat, rpel, qst
2585  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
2586  common /hermt/afxt(22), afyt(22), afzt(22)
2587  common /hermd/afxm(20), afym(20), afzm(20)
2588  common /hermr/afxr(20), afyr(20), afzr(20)
2589  common /hermrr/afxrr(20), afyrr(20), afzrr(20)
2590  common /sizr/xrms3, yrms3, zrms3, zcgr3
2591  common /degherm/nmaz, nmazr, nmaxy
2592  common /sizt/xrms, yrms, zrms
2593  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2594  common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
2595  common /faisc/f(10, iptsz), imax, ngood
2596  common /intgrt/ex, ey, ez
2597  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
2598  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
2599  common /twcst/epsilon
2600  common /ecor/const
2601  common /npart/imaxr
2602  common /macro/ratei
2603  logical ichaes
2604  dimension ui(6), wi(6)
2605  data (ui(j), j=1, 6)/.033765, .169395, .380690, .619310, .830605, .966234/
2606  data (wi(j), j=1, 6)/.085662, .180381, .233957, .233957, .180381, .085662/
2607 
2608  ! Initialize some constants and variables
2609  ! freq. in MHz
2610  freq = fh*0.5e-06/pi
2611  ! qmpart=coul , xrms=meters
2612  ! ireca=0 : first ellipsoid over nmaxy terms
2613  ! ireca=4 : one ellipsoid over the first term
2614  xrmsc = 0.
2615  yrmsc = 0.
2616  zrmsc = 0.
2617  xgc = 0.
2618  ygc = 0.
2619  zgc = 0.
2620  if (ireca==0 .or. ireca==4) then
2621  xrmsc = xrms1
2622  yrmsc = yrms1
2623  zrmsc = zrms1
2624  xgc = xcgd
2625  ygc = ycgd
2626  zgc = zcgd
2627  end if
2628  ! ireca=1 : second ellipsoid
2629  if (ireca==1) then
2630  xrmsc = xrms2
2631  yrmsc = yrms2
2632  zrmsc = zrms2
2633  xgc = xcgr
2634  ygc = ycgr
2635  zgc = zcgr
2636  end if
2637  ! ireca=2 : third elllipsoid
2638  if (ireca==2) then
2639  xrmsc = xrms3
2640  yrmsc = yrms3
2641  zrmsc = zrms3
2642  xgc = 0.
2643  ygc = 0.
2644  zgc = zcgr3
2645  end if
2646  qmpart = 1.0e-09*beamc/(float(imax)*freq)
2647  ! omment const=qmpart*xrmsc*yrmsc*zrmsc/(2.*epsilon)
2648  qmpart = qmpart*ratei
2649  const = qmpart/(2.*epsilon)
2650  dnorm = (xrmsc*yrmsc*zrmsc)**.333333333
2651  dsq = dnorm*dnorm
2652  xsq = (xc(npt)-xgc)*(xc(npt)-xgc)
2653  ysq = (yc(npt)-ygc)*(yc(npt)-ygc)
2654  zsq = (zc(npt)-zgc)*(zc(npt)-zgc)
2655  if (ireca==0) zc1 = zc(npt) - zgc
2656  if (ireca==1) zc2 = zc(npt) - zgc
2657  ex = 0.
2658  if (ireca==2) zc2 = zc(npt) - zgc
2659  ey = 0.
2660  ez = 0.
2661  ! initialize integrals to 0.
2662  ! integrate all 3 components (x,y,z)
2663  do j = 1, 6
2664  a1 = xrmsc*xrmsc - dsq + dsq/ui(j)
2665  a2 = yrmsc*yrmsc - dsq + dsq/ui(j)
2666  a3 = zrmsc*zrmsc - dsq + dsq/ui(j)
2667  t1 = xsq/a1
2668  t2 = ysq/a2
2669  t3 = zsq/a3
2670  txyz = sqrt(t1+t2+t3)
2671  ff1 = drxyz(nmaxy, txyz, ireca)/(ui(j)*ui(j)*sqrt(a1*a2*a3))
2672  fxn = ff1/a1
2673  fyn = ff1/a2
2674  fzn = ff1/a3
2675  ex = ex + wi(j)*fxn*dsq
2676  ey = ey + wi(j)*fyn*dsq
2677  ez = ez + wi(j)*fzn*dsq
2678  end do
2679  ! Field components are in Newton/Coulomb
2680  ex = ex*const*xc(npt)
2681  ey = ey*const*yc(npt)
2682  ez = ez*const*(zc(npt)-zgc)
2683  return
2684  end subroutine intga
2685  ! *******************************************************************
2686  ! SUBROUTINE sizcor(ect,xrms,yrms,zrms,imaxd)
2687  ! Computes the R.M.S. of the bunch at positions of space charge
2688  ! computation
2689  ! *******************************************************************
2690  subroutine sizcor(ect, xrms, yrms, zrms, imaxd)
2691  implicit real *8(a-h, o-z)
2692  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
2693  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
2694  common /cgrms/xsum, ysum, zsum
2695  common /faisc/f(10, iptsz), imax, ngood
2696 
2697  imaxf = 0
2698  imaxx = ngood
2699  xsum = 0.
2700  ysum = 0.
2701  zsum = 0.
2702  xrmsp = xrms
2703  yrmsp = yrms
2704  zrmsp = zrms
2705  xsqsum = 0.
2706  ysqsum = 0.
2707  zsqsum = 0.
2708  if (imaxd>0) imaxx = imaxd
2709  do i = 1, imaxx
2710  xcoup = abs(xc(i)/xrmsp)
2711  ycoup = abs(yc(i)/yrmsp)
2712  zcoup = abs(zc(i)/zrmsp)
2713  if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
2714  xsum = xsum + xc(i)
2715  ysum = ysum + yc(i)
2716  zsum = zsum + zc(i)
2717  xsqsum = xsqsum + xc(i)*xc(i)
2718  ysqsum = ysqsum + yc(i)*yc(i)
2719  zsqsum = zsqsum + zc(i)*zc(i)
2720  imaxf = imaxf + 1
2721  end if
2722  end do
2723  xsum = xsum/imaxf
2724  ysum = ysum/imaxf
2725  zsum = zsum/imaxf
2726  xsqsum = xsqsum/imaxf
2727  ysqsum = ysqsum/imaxf
2728  zsqsum = zsqsum/imaxf
2729  xrms = sqrt(xsqsum-xsum*xsum)
2730  yrms = sqrt(ysqsum-ysum*ysum)
2731  zrms = sqrt(zsqsum-zsum*zsum)
2732  return
2733  end subroutine sizcor
2734  ! *******************************************************************
2735  ! SUBROUTINE sizrms(imaxd,xrms,yrms,zrms,zmin)
2736  ! partial R.M.S. (called by SCHERM)
2737  ! *******************************************************************
2738  subroutine sizrms(imaxd, xrms, yrms, zrms, zmin)
2739  implicit real *8(a-h, o-z)
2740  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
2741  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
2742  common /cgrms/xsum, ysum, zsum
2743  common /faisc/f(10, iptsz), imax, ngood
2744 
2745  imaxx = ngood
2746  xsum = 0.
2747  ysum = 0.
2748  zsum = 0.
2749  if (imaxd>0) then
2750  do i = 1, imaxd
2751  zc(i) = zc(i) - zmin
2752  end do
2753  imaxx = imaxd
2754  end if
2755  xsqsum = 0.
2756  ysqsum = 0.
2757  zsqsum = 0.
2758  do i = 1, imaxx
2759  xsum = xsum + xc(i)
2760  ysum = ysum + yc(i)
2761  zsum = zsum + zc(i)
2762  xsqsum = xsqsum + xc(i)*xc(i)
2763  ysqsum = ysqsum + yc(i)*yc(i)
2764  zsqsum = zsqsum + zc(i)*zc(i)
2765  end do
2766  xsum = xsum/imaxx
2767  ysum = ysum/imaxx
2768  zsum = zsum/imaxx
2769  xsqsum = xsqsum/float(imaxx)
2770  ysqsum = ysqsum/float(imaxx)
2771  zsqsum = zsqsum/float(imaxx)
2772  xrms = sqrt(xsqsum-xsum*xsum)
2773  yrms = sqrt(ysqsum-ysum*ysum)
2774  zrms = sqrt(zsqsum-zsum*zsum)
2775  return
2776  end subroutine sizrms
2777  ! *******************************************************************
2778  ! FUNCTION snzt(CC,DD)
2779  ! specific function called by SCHERM
2780  ! *******************************************************************
2781  function snzt(cc, dd)
2782  implicit real *8(a-h, o-z)
2783  common /degherm/nmaz, nmazr, nmaxy
2784  common /sizt/xrms, yrms, zrms
2785  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2786  common /gaus17/h1(17), t1(17)
2787 
2788  snzt = 0.
2789  do i = 1, 17
2790  z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2791  denz = densz(nmaz, z, 0)
2792  if (denz<0.) denz = 0.
2793  snzt = snzt + t1(i)*denz
2794  end do
2795  snzt = snzt*(dd-cc)/2.
2796  return
2797  end function snzt
2798  ! *******************************************************************
2799  ! FUNCTION snzd(cc,dd)
2800  ! specific function called by SCHERM
2801  ! *******************************************************************
2802  function snzd(cc, dd)
2803  implicit real *8(a-h, o-z)
2804  common /degherm/nmaz, nmazr, nmaxy
2805  common /sizt/xrms, yrms, zrms
2806  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2807  common /gaus17/h1(17), t1(17)
2808 
2809  snzd = 0.
2810  do i = 1, 17
2811  z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2812  denz = densz(nmaz, z, 0)
2813  if (denz<0.) go to 13
2814  zz = (z-cc)
2815  snzd = snzd + t1(i)*denz
2816  end do
2817 13 continue
2818  snzd = snzd*(dd-cc)
2819  return
2820  end function snzd
2821  ! *******************************************************************
2822  ! FUNCTION vaprz(CC,DD)
2823  ! specific function called by SCHERM
2824  ! *******************************************************************
2825  function vaprz(cc, dd)
2826  implicit real *8(a-h, o-z)
2827  common /degherm/nmaz, nmazr, nmaxy
2828  common /sizt/xrms, yrms, zrms
2829  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2830  common /gaus17/h1(17), t1(17)
2831 
2832  vaprz = 0.
2833  var1 = 0.
2834  var2 = 0.
2835  do i = 1, 17
2836  z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2837  denz = densz(nmaz, z, 0)
2838  if (denz<0.) go to 13
2839  zz = (z-cc)
2840  var1 = var1 + t1(i)*zz*zz*denz
2841  var2 = var2 + t1(i)*denz
2842  end do
2843 13 continue
2844  vaprz = var1/var2
2845  return
2846  end function vaprz
2847  ! *******************************************************************
2848  ! FUNCTION prinz(CC,DD,KAP,ZRMSS1)
2849  ! specific function called by SCHERM
2850  ! *******************************************************************
2851  function prinz(cc, dd, kap, zrmss1)
2852  implicit real *8(a-h, o-z)
2853  common /degherm/nmaz, nmazr, nmaxy
2854  common /sizt/xrms, yrms, zrms
2855  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2856  common /gaus17/h1(17), t1(17)
2857 
2858  prinz = 0.
2859  k = kap - 1
2860  do i = 1, 17
2861  denz = 0.
2862  z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
2863  denz = densz(nmaz, z, 0)
2864  if (denz<0.) go to 13
2865  zz = (z-cc)/zrmss1
2866  prinz = prinz + t1(i)*herm(2*k, zz)*denz
2867  end do
2868 13 continue
2869  prinz = prinz*(dd-cc)/2.
2870  return
2871  end function prinz
2872  ! *******************************************************************
2873  ! SUBROUTINE rchsom(ZI,ZF,NMAZ)
2874  ! specific function called by SCHERM
2875  ! Look for the top of the partial distributions
2876  ! *******************************************************************
2877  subroutine rchsom(zi, zf, nmaz)
2878  implicit real *8(a-h, o-z)
2879 
2880  xpz = abs((zf-zi))/400.
2881 1 continue
2882  ztest = abs(zf-zi)
2883  if (ztest<=xpz) return
2884  z1 = (zf+zi)/2.
2885  z2 = (z1+zi)/2.
2886  t1 = densz(nmaz, z1, 0)
2887  t2 = densz(nmaz, z2, 0)
2888  ! new interval: Z2,ZF
2889  if (t1>t2) zi = z2
2890  ! new interval : ZI,Z1
2891  if (t1<t2) zf = z1
2892  go to 1
2893  end subroutine rchsom
2894  ! *******************************************************************
2895  ! SUBROUTINE rchsor(AA,BB,CC,DD,ZS)
2896  ! specific function called by SCHERM
2897  ! Look for the top of the partial distributions
2898  ! *******************************************************************
2899  subroutine rchsor(aa, bb, cc, dd, zs)
2900  implicit real *8(a-h, o-z)
2901 
2902  zi = aa
2903  zf = cc
2904  xpz = abs((zf-zi))/400.
2905 1 continue
2906  ztest = abs(zf-zi)
2907  if (ztest<=xpz) then
2908  zs = (zi+zf)/2.
2909  return
2910  end if
2911  z1 = (zf+zi)/2.
2912  z2 = (z1+zi)/2.
2913  t1 = dendif(z1, aa, bb, cc, dd)
2914  t2 = dendif(z2, aa, bb, cc, dd)
2915  ! NEW INTERVAL : Z2,ZF
2916  if (t1>t2) zi = z2
2917  ! NEW INTERVAL : ZI,Z1
2918  if (t1<t2) zf = z1
2919  go to 1
2920  end subroutine rchsor
2921  ! *******************************************************************
2922  ! FUNCTION herm(M,X)
2923  ! Hermite polynomials
2924  ! *******************************************************************
2925  function herm(m, x)
2926  implicit real *8(a-h, o-z)
2927  dimension he(30)
2928 
2929  if (m==0) then
2930  herm = 1.
2931  return
2932  end if
2933  if (m==1) then
2934  herm = x
2935  return
2936  end if
2937  he(1) = 1.
2938  he(2) = x
2939  m1 = m - 1
2940  do k = 1, m1
2941  he(k+2) = x*he(k+1) - float(k)*he(k)
2942  end do
2943  herm = he(m+1)
2944  return
2945  end function herm
2946  ! *******************************************************************
2947  ! FUNCTION densz(M,Z,IRECA)
2948  ! called by SCHERM
2949  ! Look for the distribution in z position
2950  ! *******************************************************************
2951  function densz(m, z, ireca)
2952  implicit real *8(a-h, o-z)
2953  common /hermt/afxt(22), afyt(22), afzt(22)
2954  common /hermd/afxm(20), afym(20), afzm(20)
2955  common /hermr/afxr(20), afyr(20), afzr(20)
2956 
2957  densz = 0.
2958  do k = 1, m
2959  kap = k - 1
2960  if (ireca==0) densz = densz + exp(-z*z/2.)*afzt(k)*herm(kap, z)
2961  if (ireca==2) densz = densz + exp(-z*z/2.)*afzm(k)*herm(2*kap, z)
2962  if (ireca==3) densz = densz + exp(-z*z/2.)*afzr(k)*herm(2*kap, z)
2963  end do
2964  return
2965  end function densz
2966  ! *******************************************************************
2967  ! FUNCTION codsy(BB,CC,DD,EE,KAP)
2968  ! specific function called by SCHERM
2969  ! *******************************************************************
2970  function codsy(bb, cc, dd, ee, kap)
2971  implicit real *8(a-h, o-z)
2972  common /degherm/nmaz, nmazr, nmaxy
2973  common /sizt/xrms, yrms, zrms
2974  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
2975  common /gaus13/h(13), t(13)
2976 
2977  codsy = 0.
2978  k = kap - 1
2979  ff = 2.*ee - cc
2980  do i = 1, 13
2981  dendifr = 0.
2982  z = (cc+ff)/2. + (cc-ff)*t(i)/2.
2983  if (z>=ff .and. z<ee) then
2984  zs = 2.*ee - z
2985  z1 = dd + bb - zs
2986  if (zs<bb) dendifr = densz(nmaz, zs, 0)
2987  if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
2988  end if
2989  if (z>=ee) then
2990  if (z<bb) dendifr = densz(nmaz, z, 0)
2991  z1 = dd + bb - z
2992  if (z>=bb) dendifr = densz(nmaz, z, 0) - densz(nmaz, z1, 0)
2993  end if
2994  if (dendifr<0.) dendifr = 0.
2995  zz = z - ee
2996  ! ZRMS2(EFFECTIF)=ZRMS2(CALCULE)*ZRMS
2997  zz = zz/zrms2
2998  codsy = codsy + h(i)*herm(2*k, zz)*dendifr
2999  end do
3000  codsy = codsy*(cc-ff)/2.
3001  return
3002  end function codsy
3003  ! *******************************************************************
3004  ! FUNCTION codif(BB,CC,DD,EE,EE1,KAP)
3005  ! specific function called by SCHERM
3006  ! *******************************************************************
3007  function codif(bb, cc, dd, ee, ee1, kap)
3008  implicit real *8(a-h, o-z)
3009  common /degherm/nmaz, nmazr, nmaxy
3010  common /sizt/xrms, yrms, zrms
3011  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3012  common /sizr/xrms3, yrms3, zrms3, zcgr3
3013  common /gaus13/h(13), t(13)
3014 
3015  codif = 0.
3016  k = kap - 1
3017  ff = 2.*ee1 - ee
3018  ff1 = 2.*ee - cc
3019  dendifr = 0.
3020  do i = 1, 13
3021  z = (ee+ff)/2. + (ee-ff)*t(i)/2.
3022  if (z<=ff1) dendifr = densz(nmaz, z, 0)
3023  if (z>=ff1) then
3024  zs = 2.*ee - z
3025  z1 = dd + bb - zs
3026  if (zs<bb) dendifr = densz(nmaz, zs, 0)
3027  if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
3028  dendifr = densz(nmaz, z, 0) - dendifr
3029  end if
3030  if (z>0.) dendifr = 0.
3031  if (dendifr<0.) dendifr = 0.
3032  zz = z - ee1
3033  ! ZRMS2(EFFECTIF)=ZRMS2(CALCULE)*ZRMS
3034  zz = zz/zrms3
3035  codif = codif + h(i)*herm(2*k, zz)*dendifr
3036  end do
3037  codif = -codif*ff/2.
3038  return
3039  end function codif
3040  ! *******************************************************************
3041  ! FUNCTION varia(BB,CC,DD,EE)
3042  ! specific function called by SCHERM
3043  ! *******************************************************************
3044  function varia(bb, cc, dd, ee)
3045  implicit real *8(a-h, o-z)
3046  common /degherm/nmaz, nmazr, nmaxy
3047  common /sizt/xrms, yrms, zrms
3048  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3049  common /gaus13/h(13), t(13)
3050 
3051  varia = 0.
3052  codi1 = 0.
3053  codi2 = 0.
3054  ff = 2.*ee - cc
3055  do i = 1, 13
3056  dendifr = 0.
3057  z = (cc+ff)/2. + (cc-ff)*t(i)/2.
3058  if (z>=ff .and. z<ee) then
3059  zs = 2.*ee - z
3060  z1 = dd + bb - zs
3061  if (zs<bb) dendifr = densz(nmaz, zs, 0)
3062  if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
3063  end if
3064  if (z>=ee) then
3065  if (z<bb) dendifr = densz(nmaz, z, 0)
3066  z1 = dd + bb - z
3067  if (z>=bb) dendifr = densz(nmaz, z, 0) - densz(nmaz, z1, 0)
3068  end if
3069  zz = z - ee
3070  if (dendifr<0.) dendifr = 0.
3071  codi1 = codi1 + h(i)*zz*zz*dendifr
3072  codi2 = codi2 + h(i)*dendifr
3073  end do
3074  varia = codi1/codi2
3075  return
3076  end function varia
3077  ! *******************************************************************
3078  ! FUNCTION variz(BB,CC,DD,EE,EE1)
3079  ! specific function called by SCHERM
3080  ! *******************************************************************
3081  function variz(bb, cc, dd, ee, ee1)
3082  implicit real *8(a-h, o-z)
3083  common /degherm/nmaz, nmazr, nmaxy
3084  common /sizt/xrms, yrms, zrms
3085  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3086  common /gaus13/h(13), t(13)
3087 
3088  variz = 0.
3089  codi1 = 0.
3090  codi2 = 0.
3091  ff = 2.*ee1 - ee
3092  ff1 = 2.*ee - cc
3093  do i = 1, 13
3094  dendifr = 0.
3095  z = (ee+ff)/2. + (ee-ff)*t(i)/2.
3096  if (z<=ff1) dendifr = densz(nmaz, z, 0)
3097  if (z>=ff1) then
3098  zs = 2.*ee - z
3099  z1 = dd + bb - zs
3100  if (zs<bb) dendifr = densz(nmaz, zs, 0)
3101  if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
3102  dendifr = densz(nmaz, z, 0) - dendifr
3103  end if
3104  if (z>ee) dendifr = 0.
3105  if (dendifr<0.) dendifr = 0.
3106  zz = z - ee1
3107  codi1 = codi1 + h(i)*zz*zz*dendifr
3108  codi2 = codi2 + h(i)*dendifr
3109  end do
3110  variz = codi1/codi2
3111  return
3112  end function variz
3113  ! *******************************************************************
3114  ! FUNCTION grz(AA,BB,CC,DD,EE)
3115  ! specific function called by SCHERM
3116  ! *******************************************************************
3117  function grz(aa, bb, cc, dd, ee)
3118  implicit real *8(a-h, o-z)
3119  common /degherm/nmaz, nmazr, nmaxy
3120  common /sizt/xrms, yrms, zrms
3121  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3122  common /gaus13/h(13), t(13)
3123 
3124  grz = 0.
3125  gz = 0.
3126  gs = 0.
3127  do i = 1, 13
3128  z = (ee+aa)/2. + (ee-aa)*t(i)/2.
3129  dif = dendir(z, aa, bb, cc, dd, ee)
3130  if (dif<0.) dif = 0.
3131  gz = gz + h(i)*z*dif
3132  gs = gs + h(i)*dif
3133  end do
3134  if (gs<=0.) grz = 0.
3135  if (gs>0.) grz = gz/gs
3136  return
3137  end function grz
3138  ! *******************************************************************
3139  ! FUNCTION dendir(Z,AA,BB,CC,DD,EE)
3140  ! Specific function called by SCHERM
3141  ! Calculate the value (nt(z)-nm(z))
3142  ! *******************************************************************
3143  function dendir(z, aa, bb, cc, dd, ee)
3144  implicit real *8(a-h, o-z)
3145  common /degherm/nmaz, nmazr, nmaxy
3146 
3147  dendir = 0.
3148  ff = 2.*ee - cc
3149  if (z<aa) dendir = 0.
3150  if (z>=aa .and. z<ff) dendir = densz(nmaz, z, 0)
3151  if (z>=ff .and. z<ee) then
3152  zs = 2.*ee - z
3153  z1 = dd + bb - zs
3154  dendifr = 0.
3155  if (zs<bb) dendifr = densz(nmaz, zs, 0)
3156  if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
3157  dendir = densz(nmaz, z, 0) - dendifr
3158  end if
3159  if (z>=ee) dendir = 0.
3160  return
3161  end function dendir
3162  ! *******************************************************************
3163  ! FUNCTION dendif(Z,AA,BB,CC,DD)
3164  ! Specific function called by SCHERM
3165  ! Calculate the value (nt(z)-nm(z))
3166  ! *******************************************************************
3167  function dendif(z, aa, bb, cc, dd)
3168  implicit real *8(a-h, o-z)
3169  common /degherm/nmaz, nmazr, nmaxy
3170 
3171  dendif = 0.
3172  if (z<aa) dendif = 0.
3173  if (z>=aa .and. z<bb) dendif = densz(nmaz, z, 0)
3174  if (z>=bb .and. z<cc) then
3175  z1 = dd + bb - z
3176  dendif = densz(nmaz, z, 0) - densz(nmaz, z1, 0)
3177  end if
3178  if (z>=cc) dendif = 0.
3179  return
3180  end function dendif
3181  ! *******************************************************************
3182  ! FUNCTION denpd(XYZ,NMAXY,NMAZ)
3183  ! Specific function called by SCHERM
3184  ! Represents the distribution:(n(x)+n(y)+n(z))/3
3185  ! *******************************************************************
3186  function denpd(xyz, nmaxy, nmaz)
3187  implicit real *8(a-h, o-z)
3188 
3189  denpd = (densx(nmaxy,xyz,1)+densy(nmaxy,xyz,1)+densz(nmaz,xyz,2))/3.
3190  return
3191  end function denpd
3192  ! *******************************************************************
3193  ! FUNCTION drxyz(M,XYZ,IRECA)
3194  ! Specific function called by SCHERM
3195  ! Calculate the derivatives of:(n(x)+n(y)+n(z))/3
3196  ! IRECA=0 : for the first ellipse
3197  ! IRECA=1 : for the second ellipse
3198  ! IRECA=2 : for the third ellipse
3199  ! *******************************************************************
3200  function drxyz(m, xyz, ireca)
3201  implicit real *8(a-h, o-z)
3202  common /hermt/afxt(22), afyt(22), afzt(22)
3203  common /hermd/afxm(20), afym(20), afzm(20)
3204  common /hermr/afxr(20), afyr(20), afzr(20)
3205  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
3206  common /hermrr/afxrr(20), afyrr(20), afzrr(20)
3207  common /sizr/xrms3, yrms3, zrms3, zcgr3
3208  common /consta/vl, pi, xmat, rpel, qst
3209 
3210  deriv1 = 0.
3211  deriv2 = 0.
3212  if (abs(xyz)>13.) xyz = 13.
3213  fe = exp(-xyz*xyz/2.)
3214  axyz = abs(xyz)
3215  msto = m
3216  do k = 2, m
3217  kap = k - 1
3218  kah = 2*kap - 1
3219  if (ireca==0) then
3220  dxxyz = fe*float(kap)*afxm(k)*hers(kah, axyz)
3221  dyxyz = fe*float(kap)*afym(k)*hers(kah, axyz)
3222  dzxyz = fe*float(kap)*afzm(k)*hers(kah, axyz)
3223  deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
3224  end if
3225  if (ireca==1) then
3226  dxxyz = fe*float(kap)*afxr(k)*hers(kah, axyz)
3227  dyxyz = fe*float(kap)*afyr(k)*hers(kah, axyz)
3228  dzxyz = fe*float(kap)*afzr(k)*hers(kah, axyz)
3229  deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
3230  end if
3231  if (ireca==2) then
3232  dxxyz = fe*float(kap)*afxrr(k)*hers(kah, axyz)
3233  dyxyz = fe*float(kap)*afyrr(k)*hers(kah, axyz)
3234  dzxyz = fe*float(kap)*afzrr(k)*hers(kah, axyz)
3235  deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
3236  end if
3237  end do
3238  do k = 1, m
3239  kap = 2*(k-1)
3240  if (ireca==0) then
3241  dxxyz = -fe*afxm(k)*herm(kap, xyz)
3242  dyxyz = -fe*afym(k)*herm(kap, xyz)
3243  dzxyz = -fe*afzm(k)*herm(kap, xyz)
3244  deriv2 = deriv2 + .5*(dxxyz+dyxyz+dzxyz)
3245  end if
3246  if (ireca==1) then
3247  dxxyz = -fe*afxr(k)*herm(kap, xyz)
3248  dyxyz = -fe*afyr(k)*herm(kap, xyz)
3249  dzxyz = -fe*afzr(k)*herm(kap, xyz)
3250  deriv2 = deriv2 + .5*(dxxyz+dyxyz+dzxyz)
3251  end if
3252  if (ireca==2) then
3253  dxxyz = -fe*afxrr(k)*herm(kap, xyz)
3254  dyxyz = -fe*afyrr(k)*herm(kap, xyz)
3255  dzxyz = -fe*afzrr(k)*herm(kap, xyz)
3256  deriv2 = deriv2 + .5*(dxxyz+dyxyz+dzxyz)
3257  end if
3258  end do
3259  drxyz = -(deriv1+deriv2)/(3.*pi)
3260  m = msto
3261  return
3262  end function drxyz
3263  ! *******************************************************************
3264  ! FUNCTION hers(M,X)
3265  ! Specific Hermite polynomials called by the function DRXYZ
3266  ! *******************************************************************
3267  function hers(m, x)
3268  implicit real *8(a-h, o-z)
3269  dimension he(30)
3270 
3271  if (m==1) then
3272  hers = 1.
3273  return
3274  end if
3275  if (m==3) then
3276  hers = x*x - 3.
3277  return
3278  end if
3279  he(1) = 1.
3280  he(2) = x*x - 3.
3281  xm1 = float((m+1)/2) + .01
3282  m1 = int(xm1) - 2
3283  do k = 1, m1
3284  he(k+2) = herm(2*(k+2)-2, abs(x)) - float(2*(k+2)-2)*he(k+1)
3285  end do
3286  hers = he(m1+2)
3287  return
3288  end function hers
3289  ! *******************************************************************
3290  ! FUNCTION copdr(XI,XF,KAP)
3291  ! Specific function called by SCHERM
3292  ! Calculate the Hermite coefficients for :(n(x)+n(y)+n(z))/3.
3293  ! *******************************************************************
3294  function copdr(xi, xf, kap)
3295  implicit real *8(a-h, o-z)
3296  common /degherm/nmaz, nmazr, nmaxy
3297  common /gaus13/h(13), t(13)
3298 
3299  copdr = 0.
3300  k = kap - 1
3301  do i = 1, 13
3302  z = (xi+xf)/2. + (xf-xi)*t(i)/2.
3303  dend = denrs(z)
3304  copdr = copdr + h(i)*herm(2*k, z)*dend
3305  end do
3306  copdr = copdr*(xf-xi)/2.
3307  return
3308  end function copdr
3309  ! *******************************************************************
3310  ! FUNCTION densx(M,X,IRECA)
3311  ! Specific function called by SCHERM
3312  ! Calculate the distribution :(n(x)+n(y)+n(z))/3. at the x position
3313  ! *******************************************************************
3314  function densx(m, x, ireca)
3315  implicit real *8(a-h, o-z)
3316  common /hermt/afxt(22), afyt(22), afzt(22)
3317  common /hermd/afxm(20), afym(20), afzm(20)
3318  common /hermr/afxr(20), afyr(20), afzr(20)
3319 
3320  densx = 0.
3321  do k = 1, m
3322  kap = k - 1
3323  if (ireca==0) densx = densx + exp(-x*x/2.)*afxt(k)*herm(2*kap, abs(x))
3324  if (ireca==1) densx = densx + exp(-x*x/2.)*afxm(k)*herm(2*kap, abs(x))
3325  end do
3326  return
3327  end function densx
3328  ! *******************************************************************
3329  ! FUNCTION densy(M,Y,IRECA)
3330  ! Specific function called by SCHERM
3331  ! Calculate the distribution :(n(x)+n(y)+n(z))/3. at the y position
3332  ! *******************************************************************
3333  function densy(m, y, ireca)
3334  implicit real *8(a-h, o-z)
3335  common /hermt/afxt(22), afyt(22), afzt(22)
3336  common /hermd/afxm(20), afym(20), afzm(20)
3337  common /hermr/afxr(20), afyr(20), afzr(20)
3338 
3339  densy = 0.
3340  do k = 1, m
3341  kap = k - 1
3342  if (ireca==0) densy = densy + exp(-y*y/2.)*afyt(k)*herm(2*kap, abs(y))
3343  if (ireca==1) densy = densy + exp(-y*y/2.)*afym(k)*herm(2*kap, abs(y))
3344  end do
3345  return
3346  end function densy
3347  ! *******************************************************************
3348  ! FUNCTION denrs(XYZ)
3349  ! Specific function called by SCHERM
3350  ! Calculate the distribution :(n(x)+n(y)+n(z))/3. for the third
3351  ! ellipse
3352  ! *******************************************************************
3353  function denrs(xyz)
3354  implicit real *8(a-h, o-z)
3355  common /degherm/nmaz, nmazr, nmaxy
3356 
3357  sp1 = (densx(nmaxy,xyz,0)+densy(nmaxy,xyz,0))/3.
3358  sp2 = (densx(nmaxy,xyz,1)+densy(nmaxy,xyz,1))/3.
3359  denrs = sp1 - sp2 + densz(nmazr, xyz, 3)/3.
3360  return
3361  end function denrs
3362  ! *******************************************************************
3363  ! FUNCTION scgx(XI,XF)
3364  ! Specific function called by SCHERM
3365  ! Calculate the c.o.g in the x-direction for the third ellipse
3366  ! *******************************************************************
3367  function scgx(xi, xf)
3368  implicit real *8(a-h, o-z)
3369  common /degherm/nmaz, nmazr, nmaxy
3370  common /gaus13/h(13), t(13)
3371 
3372  cgx = 0.
3373  cgxx = 0.
3374  do i = 1, 13
3375  x = (xi+xf)/2. + (xf-xi)*t(i)/2.
3376  dend = (densx(nmaxy,x,0)-densx(nmaxy,x,1))
3377  cgx = cgx + h(i)*dend
3378  cgxx = cgxx + h(i)*dend*x
3379  end do
3380  cgx = cgx*(xf-xi)/2.
3381  cgxx = cgxx*(xf-xi)/2.
3382  scgx = cgxx/cgx
3383  return
3384  end function scgx
3385  ! *******************************************************************
3386  ! FUNCTION scgy(XI,XF)
3387  ! Specific function called by SCHERM
3388  ! Calculate the c.o.g in the y-direction for the third ellipse
3389  ! *******************************************************************
3390  function scgy(xi, xf)
3391  implicit real *8(a-h, o-z)
3392  common /degherm/nmaz, nmazr, nmaxy
3393  common /gaus13/h(13), t(13)
3394 
3395  cgy = 0.
3396  cgyy = 0.
3397  do i = 1, 13
3398  y = (xi+xf)/2. + (xf-xi)*t(i)/2.
3399  dend = (densy(nmaxy,y,0)-densy(nmaxy,y,1))
3400  cgy = cgy + h(i)*dend
3401  cgyy = cgyy + h(i)*dend*y
3402  end do
3403  cgy = cgy*(xf-xi)/2.
3404  cgyy = cgyy*(xf-xi)/2.
3405  scgy = cgyy/cgy
3406  return
3407  end function scgy
3408  ! *******************************************************************
3409  ! FUNCTION corxy(XI,XF,KAP,IK,XYRMS)
3410  ! Specific function called by SCHERM
3411  ! Calculate the Hermite coefficients for the third ellipse
3412  ! *******************************************************************
3413  function corxy(xi, xf, kap, ik, xyrms)
3414  implicit real *8(a-h, o-z)
3415  common /degherm/nmaz, nmazr, nmaxy
3416  common /gaus13/h(13), t(13)
3417 
3418  corxy = 0.
3419  k = kap - 1
3420  do i = 1, 13
3421  z = (xi+xf)/2. + (xf-xi)*t(i)/2.
3422  if (ik==0) dend = densx(nmaxy, z, 0) - densx(nmaxy, z, 1)
3423  if (ik==1) dend = densy(nmaxy, z, 0) - densy(nmaxy, z, 1)
3424  if (dend<0.) dend = 0.
3425  z = z/xyrms
3426  corxy = corxy + h(i)*herm(2*k, z)*dend
3427  end do
3428  corxy = corxy*(xf-xi)/2.
3429  return
3430  end function corxy
3431  ! *******************************************************************
3432  ! FUNCTION varxy(XI,XF,IK)
3433  ! Specific function called by SCHERM
3434  ! Calculate the Hermite coefficients for the residual part of the
3435  ! bunch
3436  ! *******************************************************************
3437  function varxy(xi, xf, ik)
3438  implicit real *8(a-h, o-z)
3439  common /gaus13/h(13), t(13)
3440  common /degherm/nmaz, nmazr, nmaxy
3441 
3442  varxy = 0.
3443  corxy1 = 0.
3444  corxy2 = 0.
3445  do i = 1, 13
3446  z = (xi+xf)/2. + (xf-xi)*t(i)/2.
3447  if (ik==0) dend = densx(nmaxy, z, 0) - densx(nmaxy, z, 1)
3448  if (ik==1) dend = densy(nmaxy, z, 0) - densy(nmaxy, z, 1)
3449  corxy1 = corxy1 + h(i)*z*z*dend
3450  corxy2 = corxy2 + h(i)*dend
3451  end do
3452  varxy = corxy1/corxy2
3453  return
3454  end function varxy
3455  ! *******************************************************************
3456  ! FUNCTION varzr(EE,CC,NMAZR)
3457  ! Specific function called by SCHERM
3458  ! Calculate the rms sizes of th residual part of the bunch
3459  ! *******************************************************************
3460  function varzr(ee, cc, nmazr)
3461  implicit real *8(a-h, o-z)
3462 
3463  varzr = 0.
3464  smt = densz(nmazr, 0.0d0, 3)/2.
3465  if (smt>0.) then
3466  smte = smt/1000.
3467  v1 = 0.
3468  v2 = cc - ee
3469 20 z1 = (v1+v2)/2.
3470  spl = densz(nmazr, z1, 3)
3471  if (abs(spl-smt)<=smte) go to 10
3472  if (spl>smt) then
3473  v1 = z1
3474  go to 20
3475  end if
3476  if (spl<smt) then
3477  v2 = z1
3478  go to 20
3479  end if
3480 10 continue
3481  varzr = 2.*z1/2.36
3482  else
3483  varzr = 0.
3484  end if
3485  return
3486  end function varzr
3487  ! *******************************************************************
3488  ! SUBROUTINE cdg(IDCH)
3489  ! Calculate the c.o.g. of the bunch
3490  ! IDCH EQ 1: WITH CHASE
3491  ! IDCH NE 1: OTHERWISE
3492  ! cog(1) : Energy(MeV)
3493  ! cog(3) : t.o.f. (sec)
3494  ! cog(4) : x-direction (cm)
3495  ! cog(5) : xp(mrd)
3496  ! cog(6) : y-direction (cm)
3497  ! cog(7) : yp(mrd)
3498  ! *******************************************************************
3499  subroutine cdg(idch)
3500  implicit real *8(a-h, o-z)
3501  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3502  common /faisc/f(10, iptsz), imax, ngood
3503  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
3504  common /etcom/cog(8), exten(17), fd(iptsz)
3505  common /dyn/tref, vref
3506  logical chasit
3507 
3508  cog(1) = 0.
3509  cog(3) = 0.
3510  cog(4) = 0.
3511  cog(5) = 0.
3512  cog(6) = 0.
3513  cog(7) = 0.
3514  imaxf = 0
3515  if (idch==1.) then
3516  do i = 1, ngood
3517  if (ichas(i)==1) then
3518  cog(1) = cog(1) + f(7, i)
3519  cog(3) = cog(3) + f(6, i)
3520  cog(4) = cog(4) + f(2, i)
3521  cog(5) = cog(5) + f(3, i)
3522  cog(6) = cog(6) + f(4, i)
3523  cog(7) = cog(7) + f(5, i)
3524  imaxf = imaxf + 1
3525  end if
3526  end do
3527  else
3528  do i = 1, ngood
3529  cog(1) = cog(1) + f(7, i)
3530  cog(3) = cog(3) + f(6, i)
3531  cog(4) = cog(4) + f(2, i)
3532  cog(5) = cog(5) + f(3, i)
3533  cog(6) = cog(6) + f(4, i)
3534  cog(7) = cog(7) + f(5, i)
3535  imaxf = imaxf + 1
3536  end do
3537  end if
3538  cog(1) = cog(1)/imaxf
3539  cog(3) = cog(3)/imaxf
3540  cog(4) = cog(4)/imaxf
3541  cog(5) = cog(5)/imaxf
3542  cog(6) = cog(6)/imaxf
3543  cog(7) = cog(7)/imaxf
3544  return
3545  end subroutine cdg
3546  ! *******************************************************************
3547  ! SUBROUTINE ext2d(IDCH)
3548  ! Look for average extensions squared and return them in array exten
3549  ! Used in the routines: EMIPRT ETGAP RESTAY STATIS
3550 
3551  ! IDCH EQ 1: WITH CHASE TEST
3552  ! IDCH NE 1: OTHERWISE
3553 
3554  ! cog(1) : Energy(MeV)
3555  ! cog(3) : t.o.f. (sec)
3556  ! cog(4) : x-direction (cm)
3557  ! cog(5) : xp(mrd)
3558  ! cog(6) : y-direction (cm)
3559  ! cog(7) : yp(mrd)
3560 
3561  ! exten(1) : Sum( dE*dE ) MeV*MeV
3562  ! exten(2) : Sum( dE*dPHase ) MeV*rad
3563  ! exten(3) : Sum( dPHase*dPHase ) rad*rad
3564  ! exten(4) : Sum( x*x ) cm*cm
3565  ! exten(5) : Sum( xp*xp ) mrad*mrad
3566  ! exten(6) : Sum( y*y ) cm*cm
3567  ! exten(7) : Sum( yp*yp ) mrad*mrad
3568  ! exten(8) : Sum( x*xp ) cm*mrad
3569  ! exten(9) : Sum( y*yp ) cm*mrad
3570  ! exten(12): Sum( (dp/p)*x(i) ) (cm), with p of REF
3571  ! exten(13): Sum( (dp/p)*y(i) ) (cm), with p of REF
3572  ! exten(14): Sum( (dp/p)*(dp/p) ) compared to p of REF
3573  ! exten(15): Sum( (dp/p)*x(i) ) (cm), with p of COG
3574  ! exten(16): Sum( (dp/p)*y(i) ) (cm), with p of COG
3575  ! exten(17): Sum( (dp/p)*(dp/p) ) compared to p of COG
3576  ! *******************************************************************
3577  subroutine ext2d(idch)
3578  implicit real *8(a-h, o-z)
3579  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3580  common /consta/vl, pi, xmat, rpel, qst
3581  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
3582  common /faisc/f(10, iptsz), imax, ngood
3583  common /qmoyen/qmoy
3584  common /dyn/tref, vref
3585  common /dyni/vrefi, trefi, fhinit, acpt
3586  common /etcom/cog(8), exten(17), fd(iptsz)
3587  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
3588  dimension ffd(iptsz)
3589  logical chasit, acpt
3590 
3591  exten(1) = 0.
3592  exten(2) = 0.
3593  exten(3) = 0.
3594  exten(4) = 0.
3595  exten(5) = 0.
3596  exten(6) = 0.
3597  exten(7) = 0.
3598  exten(8) = 0.
3599  exten(9) = 0.
3600  exten(12) = 0.
3601  exten(13) = 0.
3602  exten(14) = 0.
3603  exten(15) = 0.
3604  exten(16) = 0.
3605  exten(17) = 0.
3606  qmoy = 0.
3607  ! --- imaxf: particles keep in the bunch. With CHASE imaxf may be different from ngood(i.e. imaxf < ngood)
3608  imaxf = 0
3609  gcog = cog(1)/xmat
3610  bcog = sqrt(1.-1./(gcog*gcog))
3611  if (acpt) then
3612  bref = vrefi/vl
3613  else
3614  bref = vref/vl
3615  end if
3616  gref = 1./sqrt(1.-bref*bref)
3617  do i = 1, ngood
3618  gpai = f(7, i)/xmat
3619  if (gpai>1) then
3620  bpai = sqrt(1.-1./(gpai*gpai))
3621  else
3622  bpai = 0.
3623  gpai = 1.
3624  end if
3625  fd(i) = (gpai*bpai)/(gref*bref)
3626  ffd(i) = (gpai*bpai)/(gcog*bcog)
3627  end do
3628  do i = 1, ngood
3629  fdpp = fd(i) - 1.
3630  ffdpp = ffd(i) - 1.
3631  fdp = f(7, i) - cog(1)
3632  trph1 = fh*(f(6,i)-cog(3))
3633  trxf = f(2, i) - cog(4)
3634  trtf = f(3, i) - cog(5)
3635  tryf = f(4, i) - cog(6)
3636  trpf = f(5, i) - cog(7)
3637  ! --- with CHASE
3638  if (idch==1 .and. ichas(i)==1) then
3639  exten(1) = exten(1) + fdp**2
3640  exten(2) = exten(2) + trph1*fdp
3641  exten(3) = exten(3) + trph1**2
3642  exten(4) = exten(4) + trxf**2
3643  exten(5) = exten(5) + trtf**2
3644  exten(6) = exten(6) + tryf**2
3645  exten(7) = exten(7) + trpf**2
3646  exten(8) = exten(8) + trxf*trtf
3647  exten(9) = exten(9) + tryf*trpf
3648  exten(12) = exten(12) + fdpp*trxf
3649  exten(13) = exten(13) + fdpp*tryf
3650  exten(14) = exten(14) + fdpp**2
3651  exten(15) = exten(15) + ffdpp*trxf
3652  exten(16) = exten(16) + ffdpp*tryf
3653  exten(17) = exten(17) + ffdpp**2
3654  qmoy = qmoy + f(9, i)
3655  imaxf = imaxf + 1
3656  end if
3657  ! --- without CHASE
3658  if (idch/=1) then
3659  exten(1) = exten(1) + fdp**2
3660  exten(2) = exten(2) + trph1*fdp
3661  exten(3) = exten(3) + trph1**2
3662  exten(4) = exten(4) + trxf**2
3663  exten(5) = exten(5) + trtf**2
3664  exten(6) = exten(6) + tryf**2
3665  exten(7) = exten(7) + trpf**2
3666  exten(8) = exten(8) + trxf*trtf
3667  exten(9) = exten(9) + tryf*trpf
3668  exten(12) = exten(12) + fdpp*trxf
3669  exten(13) = exten(13) + fdpp*tryf
3670  exten(14) = exten(14) + fdpp**2
3671  exten(15) = exten(15) + ffdpp*trxf
3672  exten(16) = exten(16) + ffdpp*tryf
3673  exten(17) = exten(17) + ffdpp**2
3674  qmoy = qmoy + f(9, i)
3675  imaxf = imaxf + 1
3676  end if
3677  end do
3678  do i = 1, 9
3679  exten(i) = exten(i)/float(imaxf)
3680  end do
3681  do i = 12, 17
3682  exten(i) = exten(i)/float(imaxf)
3683  end do
3684  qmoy = qmoy/float(imaxf)
3685  return
3686  end subroutine ext2d
3687  ! *******************************************************************
3688  ! SUBROUTINE ext2(IDCH)
3689  ! Looks for average extensions squared and return them in array exten
3690  ! Used in the routines: stapl tiltbm ytzp
3691 
3692  ! IDCH EQ 1: WITH CHASE TEST
3693  ! IDCH NE 1: OTHERWISE
3694 
3695  ! cog(1) : Energy(MeV)
3696  ! cog(3) : t.o.f. (sec)
3697  ! cog(4) : x-direction (cm)
3698  ! cog(5) : xp(mrd)
3699  ! cog(6) : y-direction (cm)
3700  ! cog(7) : yp(mrd)
3701 
3702  ! exten(1) : Sum( (dp/p)*(dp/p) ) compared to p of COG
3703  ! exten(2) : Sum( (dp/p)*phase ) (rad)
3704  ! exten(3) : Sum( phase*phase) ) (rad*rad)
3705  ! exten(4) : Sum( x(i)*x(i) ) cm*cm
3706  ! exten(5) : Sum( xp(i)*xp(i) ) mrad*mrad
3707  ! exten(6) : Sum( y(i)*y(i) ) cm*cm
3708  ! exten(7) : Sum( yp(i)*yp(i) ) mrad*mrad
3709  ! exten(8) : Sum( x(i)*xp(i) ) cm*mrad
3710  ! exten(9) : Sum( y(i)*yp(i) ) cm*mrad
3711  ! exten(10): Sum( dE*dE ) (MeV*MeV)
3712  ! exten(11): Sum( dE*phase ) (MeV*rad)
3713  ! exten(12): Sum( (dp/p)*x(i) ) (cm), with p of REF
3714  ! exten(13): Sum( (dp/p)*y(i) ) (cm), with p of REF
3715  ! exten(14): Sum( (dp/p)*(dp/p) ) compared to p of REF
3716  ! exten(15): Sum( (dp/p)*x(i) ) (cm), with p of COG
3717  ! exten(16): Sum( (dp/p)*y(i) ) (cm), with p of COG
3718  ! exten(17): Sum( (dp/p)*(dp/p) ) compared to p of COG
3719  ! *******************************************************************
3720  subroutine ext2(idch)
3721  implicit real *8(a-h, o-z)
3722  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3723  common /consta/vl, pi, xmat, rpel, qst
3724  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
3725  common /faisc/f(10, iptsz), imax, ngood
3726  common /qmoyen/qmoy
3727  common /dyn/tref, vref
3728  common /dyni/vrefi, trefi, fhinit, acpt
3729  common /etcom/cog(8), exten(17), fd(iptsz)
3730  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
3731  dimension fdd(iptsz)
3732  logical chasit, acpt
3733  ! EXT2 looks for average extensions squared and returns them in exten(14)
3734  exten(1) = 0.
3735  exten(2) = 0.
3736  exten(3) = 0.
3737  exten(4) = 0.
3738  exten(5) = 0.
3739  exten(6) = 0.
3740  exten(7) = 0.
3741  exten(8) = 0.
3742  exten(9) = 0.
3743  exten(10) = 0.
3744  exten(11) = 0.
3745  exten(12) = 0.
3746  exten(13) = 0.
3747  exten(14) = 0.
3748  exten(15) = 0.
3749  exten(16) = 0.
3750  exten(17) = 0.
3751  qmoy = 0.
3752  imaxf = 0
3753  gcog = cog(1)/xmat
3754  bcog = sqrt(1.-1./(gcog*gcog))
3755  if (acpt) then
3756  bref = vrefi/vl
3757  else
3758  bref = vref/vl
3759  end if
3760  gref = 1./sqrt(1.-bref*bref)
3761  do i = 1, ngood
3762  gpai = f(7, i)/xmat
3763  if (gpai>1) then
3764  bpai = sqrt(1.-1./(gpai*gpai))
3765  else
3766  bpai = 0.
3767  gpai = 1.
3768  end if
3769  fd(i) = (gpai*bpai)/(gcog*bcog)
3770  fdd(i) = (gpai*bpai)/(gref*bref)
3771  end do
3772  do i = 1, ngood
3773  fdp = fd(i) - 1.
3774  fddp = fdd(i) - 1.
3775  dener = f(7, i) - cog(1)
3776  trph1 = fh*(f(6,i)-cog(3))
3777  trxf = f(2, i) - cog(4)
3778  trtf = f(3, i) - cog(5)
3779  tryf = f(4, i) - cog(6)
3780  trpf = f(5, i) - cog(7)
3781  if (idch==1 .and. ichas(i)==1) then
3782  exten(1) = exten(1) + fdp**2
3783  exten(2) = exten(2) + trph1*fdp
3784  exten(3) = exten(3) + trph1**2
3785  exten(4) = exten(4) + trxf**2
3786  exten(5) = exten(5) + trtf**2
3787  exten(6) = exten(6) + tryf**2
3788  exten(7) = exten(7) + trpf**2
3789  exten(8) = exten(8) + trxf*trtf
3790  exten(9) = exten(9) + tryf*trpf
3791  exten(10) = exten(10) + dener*dener
3792  exten(11) = exten(11) + dener*trph1
3793  exten(12) = exten(12) + fddp*trxf
3794  exten(13) = exten(13) + fddp*tryf
3795  exten(14) = exten(14) + fddp**2
3796  exten(15) = exten(15) + fdp*trxf
3797  exten(16) = exten(16) + fdp*tryf
3798  exten(17) = exten(17) + fdp**2
3799  qmoy = qmoy + f(9, i)
3800  imaxf = imaxf + 1
3801  end if
3802  if (idch/=1) then
3803  exten(1) = exten(1) + fdp**2
3804  exten(2) = exten(2) + trph1*fdp
3805  exten(3) = exten(3) + trph1**2
3806  exten(4) = exten(4) + trxf**2
3807  exten(5) = exten(5) + trtf**2
3808  exten(6) = exten(6) + tryf**2
3809  exten(7) = exten(7) + trpf**2
3810  exten(8) = exten(8) + trxf*trtf
3811  exten(9) = exten(9) + tryf*trpf
3812  exten(10) = exten(10) + dener*dener
3813  exten(11) = exten(11) + dener*trph1
3814  exten(12) = exten(12) + fddp*trxf
3815  exten(13) = exten(13) + fddp*tryf
3816  exten(14) = exten(14) + fddp**2
3817  exten(15) = exten(15) + fdp*trxf
3818  exten(16) = exten(16) + fdp*tryf
3819  exten(17) = exten(17) + fdp**2
3820  qmoy = qmoy + f(9, i)
3821  imaxf = imaxf + 1
3822  end if
3823  end do
3824  do i = 1, 17
3825  exten(i) = exten(i)/float(imaxf)
3826  end do
3827  qmoy = qmoy/float(imaxf)
3828  return
3829  end subroutine ext2
3830  ! *******************************************************************
3831  ! SUBROUTINE chrefe
3832  ! change of reference frame
3833  ! ENTRY : XC YC A
3834  ! XC : DISPLACEMENT IN THE HORIZONTAL DIRECTION (CM)
3835  ! YC : DISPLACEMENT IN THE VERTICAL DIRECTION (CM)
3836  ! A : ROTATION ABOUT THE vertical AXIS (DEG)
3837  ! *******************************************************************
3838  subroutine chrefe
3839  implicit real *8(a-h, o-z)
3840  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3841  common /consta/vl, pi, xmat, rpel, qst
3842  common /faisc/f(10, iptsz), imax, ngood
3843  common /qmoyen/qmoy
3844  common /tapes/in, ifile, meta
3845 
3846  read (in, *) xc, yc, a
3847  a = a*pi/180.
3848  write (16, 100) xc, yc, a
3849  do i = 1, ngood
3850  x = f(2, i)
3851  xp = f(3, i)*0.001
3852  yp = f(5, i)*0.001
3853  y = f(4, i)
3854  x0 = x
3855  x = ((x-yc)*cos(xp)+xc*sin(xp))/cos(xp-a)
3856  xp = xp - a
3857  xl = xc - x*sin(a)
3858  yl = yc - x0 + x*cos(a)
3859  dl = sqrt(xl*xl+yl*yl)
3860  dl = sign(dl, xl)
3861  y = y + dl*tan(yp)
3862  f(2, i) = x
3863  f(3, i) = xp*1000.
3864  f(4, i) = y
3865  f(5, i) = yp*1000.
3866  end do
3867 100 format (' New reference frame XC =', f6.2, ' CM , YC =', f6.2, ' CM , A =', f6.4, ' RADIAN', ///)
3868  return
3869  end subroutine chrefe
3870  ! *******************************************************************
3871  ! SUBROUTINE etac
3872  ! Several charge states in the bunch, generated randomly
3873  ! ENTRY :
3874  ! N : Number of charge states (maximum 6 different charge states)
3875  ! CHARGE(I) PCENT(I) EOFF (I = 1 to N )
3876  ! CHARGE(I) : charge state
3877  ! PCENT(I) : percentage of charge state
3878  ! EOFF(I) : absolute energy offset of charge state w.r.t. COG (MeV)
3879  ! ix : RANDOM NUMBER GENERATOR
3880  ! *******************************************************************
3881  subroutine etac
3882  implicit real *8(a-h, o-z)
3883  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
3884  common /consta/vl, pi, xmat, rpel, qst
3885  common /faisc/f(10, iptsz), imax, ngood
3886  common /qmoyen/qmoy
3887  common /tapes/in, ifile, meta
3888  common /mcs/imcs, ncstat, cstat(20)
3889  dimension charge(20), pcent(20), charm(20), pc(20), eoff(20), vecx(1)
3890  dimension foo(20, 9), ndp(20)
3891  character *80 myfile
3892 
3893  read (in, *) ncstat
3894  n = ncstat
3895  if (n>20) then
3896  write (16, 140) n
3897  stop
3898  end if
3899  imcs = 1
3900  if (n==0) then
3901  ! read charge state distribution from file
3902  read (in, 3333) myfile(1:80)
3903 3333 format (a80)
3904  write (16, *) 'Charge state distribution file: ', myfile(1:80)
3905  open (56, file=myfile, status='unknown')
3906  read (56, *) ntot
3907  write (16, *) 'Maximum number of particles:', imax
3908  write (16, *) 'Number of good particles:', ngood
3909  write (16, *) 'Number of particles in charge state file:', ntot
3910  if (ntot<ngood) then
3911  write (16, *) 'Not enough particles in charge state file'
3912  stop
3913  end if
3914  do j = 1, ntot
3915  read (56, *) chstate
3916  f(9, i) = chstate
3917  end do
3918  close (56)
3919  else
3920  ! generate charge state distribution
3921  pourc = 0.
3922  do i = 1, n
3923  ! for each charge state read charge, percentage and energy offset
3924  read (in, *) charm(i), pc(i), eoff(i)
3925  cstat(i) = charm(i)
3926  pourc = pourc + pc(i)
3927  if (pourc>100.) then
3928  write (16, 100) i, pourc
3929  stop
3930  end if
3931  end do
3932  pourc = 0.
3933  do i = 1, n
3934  ! WRITE(16,110) charm(I),PC(I),eoff(i)
3935  pourc = pourc + pc(i)
3936  end do
3937  if (pourc/=100.) then
3938  write (16, 120) pourc
3939  stop
3940  end if
3941  j = 1
3942 25 continue
3943  ts = 500.
3944  is = 1
3945  do i = 1, n
3946  if (ts>=charm(i)) then
3947  ts = charm(i)
3948  is = i
3949  end if
3950  end do
3951  charge(j) = ts
3952  pcent(j) = pc(is)
3953  charm(is) = 1000.
3954  j = j + 1
3955  if (j<=n) go to 25
3956  write (16, *) '**********************'
3957  ! for each charge state write charge, percentage and energy offset
3958  jjj = 0
3959  do i = 1, n
3960  write (16, 110) charge(i), pcent(i), eoff(i)
3961  if (charge(i)==qst) jjj = 1
3962  end do
3963  len = 1
3964  ! FIRST TRAJECTORY HAS CHARGE STATE AS DEFINED BY INPUT
3965  pcent(1) = pcent(1)/100.
3966  do i = 2, n
3967  pcent(i) = pcent(i-1) + pcent(i)/100.
3968  end do
3969  do i = 1, imax
3970  call rlux(vecx, len)
3971  xarpha = vecx(1)
3972  if (xarpha<=pcent(1)) then
3973  f(9, i) = charge(1)
3974  f(7, i) = f(7, i) + eoff(1)
3975  else
3976  do j = 1, n - 1
3977  if (xarpha>pcent(j) .and. xarpha<=pcent(j+1)) then
3978  f(7, i) = f(7, i) + eoff(j+1)
3979  f(9, i) = charge(j+1)
3980  end if
3981  end do
3982  end if
3983  end do
3984  end if
3985  ! print energy, boro for each charge state
3986  do k = 1, ncstat
3987  ndp(k) = 0
3988  do j = 2, 7
3989  foo(k, j) = 0.
3990  end do
3991  end do
3992  do i = 1, imax
3993  do k = 1, ncstat
3994  if (f(9,i)==cstat(k)) then
3995  ndp(k) = ndp(k) + 1
3996  do j = 2, 7
3997  foo(k, j) = foo(k, j) + f(j, i)
3998  end do
3999  end if
4000  end do
4001  end do
4002  do k = 1, ncstat
4003  do j = 2, 7
4004  foo(k, j) = foo(k, j)/float(ndp(k))
4005  end do
4006  end do
4007  do k = 1, ncstat
4008  gref = foo(k, 7)/xmat
4009  bref = sqrt(1.-1./(gref*gref))
4010  xe = (gref-1.)*xmat
4011  ! magnetic rigidity
4012  bor = 3.3356*xmat*bref*gref/cstat(k)
4013  write (16, *) ' Q: ', cstat(k), ' COG : energy ', xe, ' MeV momentum ', bor, ' kG.cm'
4014  end do
4015 100 format (3x, ' WRONG PERCENTAGE IN CHARGE STATE DISTRIBUTION', /, 4x, ' CHARGE STATE ', i3, ' PERCENTAGE ', e12.5)
4016 110 format (3x, ' CHARGE STATE ', f6.1, ' PERCENTAGE ', e12.5, ' %', 4x, ' ENERGY OFFSET ', e12.5, ' MeV')
4017 120 format (3x, ' TOTAL PERCENTAGE OF ALL CHARGE STATES < 100 %', /, 4x, ' PERCENTAGE ', e12.5)
4018 140 format (3x, ' NUMBER OF CHARGE STATES : ', i3, ' GREATER THAN 20')
4019  return
4020  end subroutine etac
4021  ! *******************************************************************
4022  ! SUBROUTINE crest(betr,eqvl,xpos,bkcr,ffield)
4023  ! called by RESTAY
4024  ! Look for the beta giving the maximun energy gain
4025  ! iterative method
4026  ! *******************************************************************
4027  subroutine crest(betr, eqvl, xpos, bkcr, ffield)
4028  implicit real *8(a-h, o-z)
4029  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4030  common /func/a(200), ylg, atte, ncel, nharm
4031  common /consta/vl, pi, xmat, rpel, qst
4032 
4033  xlhe = ylg
4034  itr = 0
4035  be1 = betr
4036  be2 = betr - 8.333e-03*betr
4037  xleq = xlhe
4038 456 continue
4039  itr = itr + 1
4040  xk1 = fh/(vl*be1)
4041  xk2 = fh/(vl*be2)
4042  t1 = tta0(be1)*ffield
4043  s1 = tsb0(be1)*ffield
4044  tp1 = tta1(be1)*ffield
4045  sp1 = tsb1(be1)*ffield
4046  t2 = tta0(be2)*ffield
4047  s2 = tsb0(be2)*ffield
4048  tp2 = tta1(be2)*ffield
4049  sp2 = tsb1(be2)*ffield
4050  dts = (t1*tp1+s1*sp1)/(t1*t1+s1*s1)
4051  a1k12 = (t1*tp1+s1*sp1)/(t2*tp2+s2*sp2)
4052  a2k12 = (t2*t2+s2*s2)/(t1*t1+s1*s1)
4053  ak12 = a1k12*a2k12
4054  ak12 = 1./ak12
4055  bk12 = (xk2-xk1)/(ak12-1.)
4056  bk12 = bk12*dts
4057  desy = -4.*atan(dts*3.2/xleq)
4058  ! improve DESYNCHRONISATION
4059  epsrd = 1.e-04
4060  if (abs(desy)>=epsrd) then
4061  til2 = desy/2.
4062  do iii = 1, 3
4063  ftil = til2/tan(til2) - 1. - bk12
4064  dftil = -til2/(sin(til2)*sin(til2)) + 1./tan(til2)
4065  til2 = til2 - ftil/dftil
4066  end do
4067  desy = til2*2.
4068  end if
4069  if (abs(desy)<epsrd) then
4070  xpos = (t1*sp1-s1*tp1)/(t1*t1+s1*s1)
4071  bkcr = sqrt(t1*t1+s1*s1)
4072  eqvl = xleq
4073  return
4074  end if
4075  ! calculates the equivalent length
4076  xleq = desy*(ak12-1.)/(xk2-xk1)
4077  deltk = desy/xleq
4078  xkcrt = xk1 - deltk
4079  becrt = fh/(vl*xkcrt)
4080  be1 = becrt
4081  be2 = becrt - becrt/120.
4082  go to 456
4083  end subroutine crest
4084  ! *******************************************************************
4085  ! SUBROUTINE gaus(r1,r2,z1,z2,opt,er,ez)
4086  ! called by SCHEFF
4087  ! calculate er and ez at the r and z location given in fldcom
4088  ! by gauss quadrature integration over the double
4089  ! interval from r1 to r2 and from z1 to z2.
4090  ! if opt.gt.0, determine number of integration points as follows.
4091  ! let rat = max(cr/cz,cz/cr), where cr=r2-r1, and cz=z2-z1
4092  ! if rat.le.2, use 2 x 2 point array
4093  ! if rat.gt.2, use 2 x 4 point array
4094  ! if rat.gt.4, use 2 x 6 point array
4095  ! if opt.lt.0, use 2 x 2 point array regardless of rat
4096  ! *******************************************************************
4097  subroutine gaus(r1, r2, z1, z2, opt, er, ez)
4098  implicit real *8(a-h, o-z)
4099  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4100  dimension r(6), z(6), wr(6), wz(6), xx(3, 3), wx(3, 3)
4101  data ((xx(i,j),i=1,3), j=1, 3)/.2113248654, 0.0, 0.0, .06943184420, .33000947820, 0.0, .03376524290, .16939530680, &
4102  .3806904070/
4103  data ((wx(i,j),i=1,3), j=1, 3)/.50, 0.0, 0.0, .17392742260, .32607257740, 0.0, .085662246190, .1803807865000, &
4104  .2339569673000/
4105 
4106  cr = r2 - r1
4107  cz = z2 - z1
4108  ir = 1
4109  jz = 1
4110  m = 1
4111  if (opt<0.) go to 20
4112  ! ---determine number of integration points
4113  rat = abs(cz/cr)
4114  l = 0
4115  if (rat>=1.) go to 10
4116  rat = 1./rat
4117  l = 1
4118 10 if (rat>2.) m = 2
4119  if (rat>4.) m = 3
4120  if (l==0) jz = m
4121  if (l==1) ir = m
4122 20 do i = 1, ir
4123  k = 2*i - 1
4124  r(k) = r1 + cr*xx(i, ir)
4125  r(k+1) = r2 - cr*xx(i, ir)
4126  wr(k) = wx(i, ir)
4127  wr(k+1) = wx(i, ir)
4128  end do
4129  do j = 1, jz
4130  k = 2*j - 1
4131  z(k) = z1 + cz*xx(j, jz)
4132  z(k+1) = z2 - cz*xx(j, jz)
4133  wz(k) = wx(j, jz)
4134  wz(k+1) = wx(j, jz)
4135  end do
4136  ser = 0.
4137  sez = 0.
4138  kr = 2*ir
4139  kz = 2*jz
4140  do i = 1, kr
4141  do j = 1, kz
4142  call flds(r(i), z(j), er1, ez1)
4143  ser = ser + wr(i)*wz(j)*er1*r(i)
4144  sez = sez + wr(i)*wz(j)*ez1*r(i)
4145  end do
4146  end do
4147  er = cr*cz*ser
4148  ez = cr*cz*sez
4149  return
4150  end subroutine gaus
4151  ! *******************************************************************
4152  ! SUBROUTINE flds(r,z,er,ez)
4153  ! called by SCHEFF
4154  ! evaluate fields at r1,z1 due to ring of charge at r,z.
4155  ! er=(pi/2)*r/d**3. ez=(pi/2)*z/d**3.
4156  ! *******************************************************************
4157  subroutine flds(r, z, er, ez)
4158  implicit real *8(a-h, o-z)
4159  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4160  common /fldcom/rp, zp, pl, opt, nip
4161 
4162  r1 = rp
4163  z1 = zp
4164  ! **********************************
4165  d = z1 - z
4166  c = (r1-r)**2
4167  b = (r1+r)**2
4168  a = 4.0*r*r1/(b+d**2)
4169  call eint(a, ee, ek)
4170  er1 = 0.0
4171  a = sqrt(b+d**2)
4172  if (r1==0.) go to 10
4173  er1 = (ek-(r**2-r1**2+d**2)*ee/(c+d**2))/(2.0*r1*a)
4174 10 ez1 = d*ee/(a*(c+d**2))
4175  if (nip==0) go to 50
4176  do i = 1, nip
4177  xi = i
4178  do j = 1, 2
4179  d = z1 - (z+xi*pl)
4180  a = 4.0*r*r1/(b+d**2)
4181  call eint(a, ee, ek)
4182  a = sqrt(b+d**2)
4183  if (r1==0.) go to 20
4184  er1 = er1 + (ek-(r**2-r1**2+d**2)*ee/(c+d**2))/(2.0*r1*a)
4185 20 ez1 = ez1 + d*ee/(a*(c+d**2))
4186  xi = -xi
4187  end do
4188  end do
4189 50 er = er1
4190  ez = ez1
4191  return
4192  end subroutine flds
4193  ! *******************************************************************
4194  ! SUBROUTINE eint(a,ee,ek)
4195  ! evaluate elliptic integrals ( called by SCHEFF)
4196  ! *******************************************************************
4197  subroutine eint(a, ee, ek)
4198  implicit real *8(a-h, o-z)
4199  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4200 
4201  b = 1.0 - a
4202  c = log(b)
4203  ee = 1.0 + b*(.4630106-0.2452740*c+b*(0.1077857-0.04125321*c))
4204  ek = 1.38629436 - .5*c + b*(0.1119697-0.1213486*c+b*(.07253230-.028874721*c))
4205  return
4206  end subroutine eint
4207  ! *******************************************************************
4208  ! SUBROUTINE tiltz(tilta)
4209  ! Skew the right ellipse generated by GEBEAM in the phase plane (x,z)
4210  ! *******************************************************************
4211  subroutine tiltz(tilta)
4212  implicit real *8(a-h, o-z)
4213  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4214  common /consta/vl, pi, xmat, rpel, qst
4215  common /faisc/f(10, iptsz), imax, ngood
4216  common /qmoyen/qmoy
4217  common /rigid/boro
4218  common /dyn/tref, vref
4219  common /tapes/in, ifile, meta
4220  common /etcom/cog(8), exten(17), fd(iptsz)
4221 
4222  write (16, 1) tilta
4223 1 format (' tilt in the plane (x,z) around the c.o.g', ' ANGLE :', e12.5, ' DEG', /)
4224  tilta = tilta*pi/180.
4225  tref = 0.
4226  vref = 0.
4227  do i = 1, imax
4228  gpai = f(7, i)/xmat
4229  vref = vref + vl*sqrt(1.-1./(gpai*gpai))
4230  tref = tref + f(6, i)
4231  end do
4232  vref = vref/float(imax)
4233  tref = tref/float(imax)
4234  vref1 = 0.
4235  tref1 = 0.
4236  do i = 1, imax
4237  gpai = f(7, i)/xmat
4238  vpai = sqrt(1.-1./(gpai*gpai))*vl
4239  trot = (f(6,i)-tref)*cos(tilta) - sin(tilta)*f(2, i)/vpai
4240  xrot = (f(6,i)-tref)*sin(tilta)*vpai + cos(tilta)*f(2, i)
4241  f(6, i) = trot
4242  f(2, i) = xrot
4243  tref1 = tref1 + f(6, i)
4244  vref1 = vref1 + vpai
4245  end do
4246  tref = tref1/float(imax)
4247  vref = vref1/float(imax)
4248  return
4249  end subroutine tiltz
4250  ! *******************************************************************
4251  ! SUBROUTINE rfq_o3
4252  ! Dynamics through a single cell of a RFQ with multipolar expansion
4253  ! units: MeV , m , sec
4254  ! p(1): V/(r0*r0) (MV/m2)
4255  ! p(2): AV (MV)
4256  ! p(3): cell length CL (m)
4257  ! p(4): phase of RF at the entrance of the cell (deg)
4258  ! p(5): TYPE
4259  ! TYPE IS 0, 1., 2., OR 3., INDICATING AS FOLLOWS
4260  ! 0, STANDARD CELL, NO ACCELERATION
4261  ! 1, STANDARD CELL, ACCELERATION
4262  ! 2, FRINGE-FIELD, NO ACCELERATION
4263  ! 3, FRINGE FIELD, ACCELERATION
4264  ! *******************************************************************
4265  subroutine rfq_o3
4266  implicit real *8(a-h, o-z)
4267  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4268  common /rigid/boro
4269  common /consta/vl, pi, xmat, rpel, qst
4270  common /dyn/tref, vref
4271  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4272  common /faisc/f(10, iptsz), imax, ngood
4273  common /tapes/in, ifile, meta
4274  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
4275  common /etcom/cog(8), exten(17), fd(iptsz)
4276  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
4277  common /fene/wdisp, wphas, wx, wy, rlim, ifw
4278  common /dcspa/iesp
4279  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
4280  common /compt/nrres, nrtre, nrbunc, nrdbun
4281  common /shif/dtiph, shift
4282  common /femt/iemgrw, iemqesg
4283  common /posc/xpsc
4284  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
4285  common /drfq/p(9)
4286  character *1 cr
4287  common /azlist/icont, iprin
4288  common /trfq/icour, ncell
4289  logical iesp, ichaes, shift, iemgrw, iflag
4290  common /itvole/itvol, imamin
4291  common /tofev/ttvols
4292  logical itvol, imamin
4293  ! allow for print out on terminal of gap# on one and the same line
4294  cr = char(13)
4295  ! omment WRITE(6,8254) NRTRE,NRRES,cr
4296  ! write(6,8254) nrtre,ncell,cr
4297  ! 8254 format('Transport element:',i5,
4298  ! * ' RFQ cell :',i5,a1,$)
4299  iflag = .false.
4300  radian = pi/180.
4301  ilost = 0
4302  twopi = 2.*pi
4303  ! convert vl in m
4304  vlm = vl/100.
4305  ! STATISTIQUES FOR PLOTS
4306  if (iprf==1) call stapl(davtot*10.)
4307  vorsq = p(1)
4308  av = p(2)
4309  cl = p(3)
4310  type = p(5)
4311  write (16, *) '*** cell :', ncell + 1, ' length (cm): ', cl*100.
4312  write (16, *) '*** V/r0**2 (kV/mm**2): ', vorsq/1000.
4313  write (16, *) '*** AV (kV): ', av*1000.
4314  if (type==0.) write (16, *) '*** no acceleration, standard cell '
4315  if (type==1.) write (16, *) '*** acceleration, standard cell '
4316  if (type==2.) write (16, *) '*** no acceleration, fringing field region '
4317  if (type==3.) write (16, *) '*** acceleration, fringing field region '
4318  wavel = 2.*pi*vlm/fh
4319  er = xmat
4320  cay = pi/cl
4321  ns = 18
4322  xl = cl/float(ns)
4323  hl = .5*xl
4324  ! ---- scl: space charge length (in cm SCHEFF unit)
4325  scl = cl*100.
4326  ! ---- c.o.g of the bunch at the entrance of the cell
4327  tcog = 0.
4328  ecog = 0.
4329  ! old qcog=0.
4330  do i = 1, ngood
4331  tcog = tcog + f(6, i)
4332  ecog = ecog + f(7, i)
4333  ! old qcog=qcog+f(9,i)
4334  end do
4335  tcog = tcog/float(ngood)
4336  ecog = ecog/float(ngood)
4337  ! old qcog=qcog/float(ngood)
4338  gcog = ecog/er
4339  bcog = sqrt(1.-1./(gcog*gcog))
4340  wcog = ecog - er
4341  if (ncell==0) then
4342  ! ---- shift = .false. ==> synchronous particle coincide with cog in the cell ncell = 0
4343  if (.not. shift) then
4344  write (16, *) '*** ref. part. and cog coincide in ncell = 0'
4345  tref = tcog
4346  bref = bcog
4347  vref = bref*vl
4348  gref = gcog
4349  wref = wcog
4350  wrefi = wref
4351  else
4352  ! ---- shift = .true. ==> the reference particle and the cog are different at the entrance of the RFQ
4353  write (16, *) '*** ref. part. and cog separated in ncell = 0'
4354  bref = vref/vl
4355  gref = 1./sqrt(1.-bref*bref)
4356  wref = er*(gref-1.)
4357  wrefi = wref
4358  end if
4359  end if
4360  if (type>1.) then
4361  cay = .5*cay
4362  ns = int(36.*cl/(bref*wavel))
4363  end if
4364  write (16, 178)
4365 178 format (/, ' Dynamics at input', /, 5x, ' BETA GAMMA ENERGY(MeV) ', ' TOF(deg) TOF(sec)')
4366  write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
4367 1788 format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
4368  write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
4369 165 format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
4370  ! start prints in file 'short.data'
4371  idav = idav + 1
4372  iitem(idav) = 14
4373  dav1(idav, 1) = cl*1000.
4374  dav1(idav, 2) = vorsq/1000.
4375  dav1(idav, 3) = av*1000
4376  davtot = davtot + cl*100.
4377  dav1(idav, 4) = davtot*10.
4378  dav1(idav, 5) = type
4379  ! ---- phini: phase of the reference at input of the cell
4380  phini = -tref*fh + p(4)*radian
4381  ph0 = phini*180./pi
4382  write (16, 3945) ph0, p(4)
4383 3945 format ('phase offset at input : ', e12.5, ' deg phase shift: ', e12.5, ' deg')
4384  ! --- the cell is divided in ns elements of length xl(m)
4385  z = 0.
4386  do n = 1, ns
4387  z = z + hl
4388  ! ---- change of synchronous particle over the half step hl = xl/2
4389  tref = tref + hl/(bref*vlm)
4390  if (itvol) ttvols = tref
4391  phref = tref*fh + phini
4392  skz = sin(cay*z)
4393  ckz = cos(cay*z)
4394  ! --- cell with fringing field (TYPE > 1)
4395  if (type>1.) then
4396  c3kz = cos(3.*cay*z)
4397  skz = .75*(skz+sin(3.*cay*z))
4398  end if
4399  ! ------ CHANGE OF ENERGY OVER STEP XL
4400  if (type/=0. .and. type/=2.) then
4401  sp = sin(phref)
4402  dwref = .5*qst*cay*av*skz*sp*xl
4403  wrefm = wref + 0.5*dwref
4404  grefm = wrefm/er + 1.
4405  brefm = sqrt(1.-1./(grefm*grefm))
4406  wref = wref + dwref
4407  gref = wref/er + 1.
4408  bref = sqrt(1.-1./(gref*gref))
4409  ! c dez=.5*qst*cay*av*skz*sp
4410  ! c dref=.5*(dez/er) * xl*xl/(brefm**3*grefm**3*vlm)
4411  end if
4412  ! start computations of particles
4413  do ip = 1, ngood
4414  ! convert in m and rad
4415  xi = f(2, ip)*1.e-02
4416  xpi = f(3, ip)*1.e-03
4417  yi = f(4, ip)*1.e-02
4418  ypi = f(5, ip)*1.e-03
4419  ww = f(7, ip) - er
4420  gi = ww/er + 1.
4421  bi = sqrt(1.-1./(gi*gi))
4422  bgi = bi*gi
4423  tim = f(6, ip) + hl/(bi*vlm)
4424  phi = phini + fh*tim
4425  qq = abs(f(9,ip))
4426  sp = sin(phi)
4427  cp = cos(phi)
4428  bav = bi
4429  gav = gi
4430  bgav = bgi
4431  bg = bgi
4432  beta = bi
4433  delt = 0.
4434  amort = 1.
4435  xm = xi + xpi*hl
4436  ym = yi + ypi*hl
4437  rm = sqrt(xm*xm+ym*ym)
4438  ! ---- the particle is lost if rm>rlim (rlim is the limit of REJECT)
4439  ! rlim is converted in m
4440  ! rlimm=rlim*1.e-02
4441  if (rm>rlimm) then
4442  f(8, ip) = 0.
4443  iflag = .true.
4444  ilost = ilost + 1
4445  write (16, 5556) ip, rm, rlimm
4446 5556 format (' particle lost: ', i5, ' radius (m): ', e12.5, ' barrier (m):', e12.5)
4447  go to 6525
4448  end if
4449  theta = 0.
4450  xml = xm
4451  yml = ym
4452  if (abs(xm)>1.e-10) theta = atan(ym/xm)
4453  if (abs(xm)<=1.e-10) then
4454  if (abs(ym)>1.e-10) then
4455  if (xm>=0. .and. ym>0.) theta = pi/2
4456  if (xm>=0. .and. ym<0.) theta = -pi/2
4457  if (xm<0. .and. ym<0.) theta = pi/2
4458  if (xm<0. .and. ym>0.) theta = -pi/2
4459  end if
4460  if (abs(ym)<=1.e-10) theta = 0.
4461  end if
4462  zrm = cay*rm
4463  ! ----- Bessel functions I0 and I1
4464  ! omment bi0=1.+zrm*zrm/4.+zrm**4/64.+zrm**6/2304.+zrm**8/1.47456e05
4465  bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
4466  bi1 = zrm/2. + zrm**3/16.
4467  ! transverse fields ex and ey
4468  erf = vorsq*cos(2.*theta)*2.*rm + cay*(av*bi1)*ckz
4469  erf = -erf/2.
4470  etf = vorsq*sin(theta)*2.*rm
4471  etf = etf/2.
4472  ex = erf*cos(theta) - etf*sin(theta)
4473  ey = erf*sin(theta) + etf*cos(theta)
4474  ! ---- change the energy over step xl
4475  if (type/=0. .and. type/=2.) then
4476  ! ---- energy at the middle of the element
4477  ! ------ standard cell
4478  if (type<2.) then
4479  ez = 0.5*(av*bi0)*skz*cay
4480  dw = qq*ez*sp*xl
4481  ! ------ fringe-field cell
4482  else
4483  dw = .5*qq*cay*avb*skz*sp*xl
4484  end if
4485  wav = ww + .5*dw
4486  ga = wav/er
4487  bgav = sqrt(ga*(2.+ga))
4488  gav = 1. + ga
4489  bav = bgav/gav
4490  ! ---- energy over the step xl
4491  ww = ww + dw
4492  ga = ww/er
4493  gam = 1. + ga
4494  bg = sqrt(ga*(2.+ga))
4495  beta = sqrt(1.-1/(gam*gam))
4496  ! calculate the jump of phase (in sec)
4497  if (type<2.) dez = qq*ez*sp
4498  if (type>2.) dez = .5*qq*cay*avb*skz*sp
4499  delt = .5*(dez/er)*xl*xl/(bav**3*gav**3*vlm)
4500  amort = bgi/bg
4501  end if
4502  bgfac = gav*bav**2
4503  ! ----- IF TYPE LT 2: standard cell
4504  if (type<2.) then
4505  cc = qq*xl*sp/(bgfac*er)
4506  signx = 1.
4507  signy = 1.
4508  if (theta>0.) then
4509  if (xm<0.) signx = -1.
4510  if (ym<0.) signy = -1.
4511  end if
4512  if (theta<0.) then
4513  if (xm<0.) signx = -1.
4514  if (ym>0.) signy = -1.
4515  end if
4516  if (theta==0.) then
4517  signx = 0.
4518  signy = 0.
4519  end if
4520  rr1 = cc*ex*signx
4521  rr2 = cc*ey*signy
4522  xpm = xpi*amort + rr1
4523  ypm = ypi*amort + rr2
4524  else
4525  ! ----- fringe-field cell (first order in transverse directions)
4526  ! *********************************************************
4527  ! C1 = (1/m**2) * (m) = (1/m)
4528  ! C2 = (1/m**2) * (m) = (1/m)
4529  ! RF1 = (MeV/(MeV*m**2)) = (1/m**2)
4530  ! RF2 = (MeV/MeV) * (1/m**2) = (1/m**2)
4531  ! *******************************************************
4532  rf1 = qq*vorb/er
4533  rf2 = .25*qq*cay*cay*avb/er
4534  c1 = rf1*sp*xl/bgfac
4535  c2 = rf2*ckz*sp*xl/bgfac
4536  c1 = c1*.75*(ckz+c3kz/3.)
4537  c2 = c2*.75*(ckz+3.*c3kz)
4538  rr1 = -(c1+c2)
4539  rr2 = (c1-c2)
4540  xpm = xpi*amort + rr1*xm
4541  ypm = ypi*amort + rr2*ym
4542  end if
4543  xf = xm + xpm*hl
4544  yf = ym + ypm*hl
4545  ! convert m->cm , rad->mrad
4546  f(2, ip) = xf*100.
4547  f(4, ip) = yf*100.
4548  f(3, ip) = xpm*1000.
4549  f(5, ip) = ypm*1000.
4550  ! tof over the length xl
4551  f(6, ip) = f(6, ip) + hl/(bi*vlm) + hl/(beta*vlm) + delt
4552  f(7, ip) = ww + er
4553  ! ----- print in file 49 coordinates of particle icont (not active)
4554  ! omment if(ip.eq.icont) then
4555  ! omment write(49,8888)n,icour,z,signx,signy,ex,ey,theta,xml,yml,rr1,rr2
4556  ! omment icour=icour+1
4557  ! omment endif
4558  ! omment8888 format(2(2x,i5),10(2x,e12.5))
4559  ! ---- ********************************************************************
4560 6525 continue
4561  end do
4562  ! ----- reshuffle good particles
4563  if (iflag) then
4564  call shuffle
4565  iflag = .false.
4566  end if
4567  ! space charge at the middle of the cell (revoir pour fringe field cell)
4568  if (n==9) then
4569  if (ichaes) then
4570  ! Charge space
4571  iesp = .true.
4572  call cesp(scl)
4573  iesp = .false.
4574  end if
4575  end if
4576  tref = tref + hl/(bref*vlm) + dref
4577  if (itvol) ttvols = tref
4578  vref = bref*vl
4579  z = z + hl
4580  ! Change dp/p over the cell
4581  call disp
4582  end do
4583  ! --- kept in the bunch particles such that phase RF > 180 deg or phase RF < -180 deg
4584  do i = 1, ngood
4585  dtvl = (f(6,i)-tref)*fh
4586  if (dtvl>pi) f(6, i) = f(6, i) - 2.*pi/fh
4587  if (dtvl<-pi) f(6, i) = f(6, i) + 2.*pi/fh
4588  end do
4589  ! ---- c.o.g of the bunch at the output of the cell
4590  tcog = 0.
4591  ecog = 0.
4592  do i = 1, ngood
4593  tcog = tcog + f(6, i)
4594  ecog = ecog + f(7, i)
4595  end do
4596  tcog = tcog/float(ngood)
4597  ecog = ecog/float(ngood)
4598  gcog = ecog/er
4599  bcog = sqrt(1.-1./(gcog*gcog))
4600  wcog = ecog - er
4601  ! --- window control relative to the energy of the c.o.g of the bunch
4602  ! ---- ifw = 0 ===> wdisp = dW/W
4603  ! ---- ifw = 1 ===> wdisp = dW (MeV)
4604  ! ----- convert wdisp in dp/p
4605  if (ifw==0) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
4606  if (ifw==1) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcog)
4607  iflag = .false.
4608  do i = 1, ngood
4609  dese = abs(fd(i)-1.)
4610  if (dese>dispr) then
4611  ilost = ilost + 1
4612  f(8, i) = 0.
4613  write (16, *) ' particle lost: ', i, ' dp/p: ', dese, ' in window :', dispr
4614  iflag = .true.
4615  end if
4616  end do
4617  if (iflag) then
4618  call shuffle
4619  ! ---- c.o.g of the bunch after shuffle
4620  tcog = 0.
4621  ecog = 0.
4622  do i = 1, ngood
4623  tcog = tcog + f(6, i)
4624  ecog = ecog + f(7, i)
4625  end do
4626  tcog = tcog/float(ngood)
4627  ecog = ecog/float(ngood)
4628  gcog = ecog/er
4629  bcog = sqrt(1.-1./(gcog*gcog))
4630  wcog = ecog - er
4631  end if
4632  write (16, 179)
4633 179 format (/, ' Dynamics at the output', /, 5x, ' BETA GAMMA ENERGY(MeV) ', &
4634  ' TOF(deg) TOF(sec)')
4635  write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
4636  write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
4637  write (16, *) ' time of flight: ', ttvols*fh*180./pi, ' deg'
4638 
4639  ! et2010s
4640  ! dphete,dav1(idav,16),dav1(idav,21) and dav1(idav,12) still to be assigned correct value
4641  dphete = 0.
4642  emns = 0.
4643  tofprt = fh*tcog*180./pi
4644  n2kp = int(tofprt/360.)
4645  tofprt = tofprt - float(n2kp)*360.
4646  if (tofprt>180.) tofprt = tofprt - 360.
4647  ! cavity number, transmission (%), synchronous phase (deg), time of flight (deg) (within –180 deg and 180 deg),
4648  ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
4649  ! (MeV),
4650  ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
4651  ! longitudinal emittance (RMS, ns.keV) <- still to be implemented (=emns)
4652  trnsms = 100.*float(ngood)/float(imax)
4653  if (ncell==1) write (50, *) '# rfq_o3.dmp'
4654  write (50, 7023) ncell, trnsms, p(4), tofprt, bcog, wccog, bets, wref, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), &
4655  0.25*emns
4656 7023 format (1x, i4, 1x, f6.2, 2(1x,f8.3), 2(1x,f7.5,1x,f11.4), 3(1x,f11.4))
4657  ! et2010e
4658 
4659  ! ---- new magnetic rigidity of the reference
4660  xmor = xmat*bref*gref
4661  boro = 33.356*xmor*1.e-01/qst
4662  dav1(idav, 6) = (gref-1.)*er - wrefi
4663  dav1(idav, 36) = ngood
4664  ! plots
4665  call stapl(davtot*10.)
4666  call emiprt(0)
4667  ncell = ncell + 1
4668  return
4669  end subroutine rfq_o3
4670  ! *******************************************************************
4671  ! SUBROUTINE tdens(m,ireca,iacc)
4672  ! called by SCHERM
4673  ! Look for the shape of the distribution n(t)
4674  ! ireca=0 : for the first ellipse
4675  ! ireca=1 : for the second ellipse
4676  ! *******************************************************************
4677  subroutine tdens(m, ireca, iacc)
4678  implicit real *8(a-h, o-z)
4679  common /hermt/afxt(22), afyt(22), afzt(22)
4680  common /hermd/afxm(20), afym(20), afzm(20)
4681  common /hermr/afxr(20), afyr(20), afzr(20)
4682  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
4683  common /consta/vl, pi, xmat, rpel, qst
4684 
4685  iacc = 0
4686  t = 1.e-05
4687  dt = 5.e-02
4688  fc = drxyz(m, t, ireca)
4689  f1 = fc
4690  do i = 1, 100
4691  t = t + dt
4692  fu = drxyz(m, t, ireca)
4693  if (fu>=fc) then
4694  fc = fu
4695  go to 10
4696  end if
4697  go to 11
4698 10 end do
4699 11 continue
4700  if (abs(fc/f1)>1.2) iacc = 1
4701  return
4702  end subroutine tdens
4703  ! *******************************************************************
4704  ! SUBROUTINE schfdyn
4705  ! Input datas for SCHEFF
4706  ! SCE(2)=r extension in rms multiples
4707  ! SCE(3)=z half extension in rms multiples
4708  ! SCE(4)=no. of radial mesh intervals (le 20)
4709  ! SCE(5)=no. of longitudinal mesh intervals (le 40)
4710  ! sce(6)=no. of adjacent bunches, applicable for buncher studies
4711  ! and should be 0 for linac dynamics
4712  ! sce(7)=pulse length, if not beta lambda.(transport studies)
4713  ! distance bewteen beam pulses
4714  ! input zero to get default "beta lambda"
4715  ! units are cm
4716  ! sce(8)=dummy
4717  ! sce(9)=option to integrate space charge forces over box
4718  ! if.eq.0. no integration. see sub gaus for further
4719  ! explanation.
4720  ! *******************************************************************
4721  subroutine schfdyn
4722  implicit real *8(a-h, o-z)
4723  common /tapes/in, ifile, meta
4724  common /rcshef/sce(20)
4725 
4726  read (in, *) iread
4727  if (iread==0) then
4728  ! standard SCHEFF parameters
4729  sce(2) = 4.
4730  sce(3) = 4.
4731  sce(4) = 20
4732  sce(5) = 40
4733  sce(6) = 0
4734  sce(9) = 0.
4735  sce(7) = 0.
4736  else
4737  ! read SCHEFF parameters
4738  read (in, *) sce(2), sce(3), sce(4), sce(5), sce(6), sce(7), sce(9)
4739  end if
4740  sce(3) = sce(3)*2.
4741  sce(8) = 0.
4742  call schefini
4743  return
4744  end subroutine schfdyn
4745  ! *******************************************************************
4746  ! SUBROUTINE intg3(npt)
4747  ! called by SCHERM
4748  ! Calculate the electric field components acting on each particle
4749  ! Gauss method
4750  ! *******************************************************************
4751  subroutine intg3(npt)
4752  implicit real *8(a-h, o-z)
4753  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4754  common /consta/vl, pi, xmat, rpel, qst
4755  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4756  common /hermt/afxt(22), afyt(22), afzt(22)
4757  common /hermd/afxm(20), afym(20), afzm(20)
4758  common /hermr/afxr(20), afyr(20), afzr(20)
4759  common /hermrr/afxrr(20), afyrr(20), afzrr(20)
4760  common /sizr/xrms3, yrms3, zrms3, zcgr3
4761  common /degherm/nmaz, nmazr, nmaxy
4762  common /sizt/xrms, yrms, zrms
4763  common /sizzt/xrmsz, yrmsz, zrmsz
4764  common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
4765  common /intgrt/ex, ey, ez
4766  common /faisc/f(10, iptsz), imax, ngood
4767  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
4768  logical ichaes
4769  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
4770  common /twcst/epsilon
4771  common /ecor/const
4772  common /cgrms/xsum, ysum, zsum
4773  common /npart/imaxr
4774  dimension ui(6), wi(6)
4775  data (ui(j), j=1, 6)/.033765, .169395, .380690, .619310, .830605, .966234/
4776  data (wi(j), j=1, 6)/.085662, .180381, .233957, .233957, .180381, .085662/
4777 
4778  ! Initialize some constants and variables
4779  ! freq. in MHz
4780  freq = fh*0.5e-06/pi
4781  xrmsc = xrmsz
4782  yrmsc = yrmsz
4783  zrmsc = zrmsz
4784  xgc = xsum
4785  ygc = ysum
4786  zgc = zsum
4787  qmpart = 1.0e-09*beamc/(float(ngood)*freq)
4788  ! omment const=qmpart*xrmsc*yrmsc*zrmsc/(2.*epsilon)
4789  const = qmpart/(2.*epsilon)
4790  dnorm = (xrmsc*yrmsc*zrmsc)**.333333333
4791  dsq = dnorm*dnorm
4792  xsq = (xc(npt)-xgc)*(xc(npt)-xgc)
4793  ysq = (yc(npt)-ygc)*(yc(npt)-ygc)
4794  zsq = (zc(npt)-zgc)*(zc(npt)-zgc)
4795  ex = 0.
4796  ey = 0.
4797  ez = 0.
4798  ! initialize integrals to 0.
4799  ! integrate all 3 components (x,y,z)
4800  do j = 1, 6
4801  a1 = xrmsc*xrmsc - dsq + dsq/ui(j)
4802  a2 = yrmsc*yrmsc - dsq + dsq/ui(j)
4803  a3 = zrmsc*zrmsc - dsq + dsq/ui(j)
4804  t1 = xsq/a1
4805  t2 = ysq/a2
4806  t3 = zsq/a3
4807  txyz = sqrt(t1+t2+t3)
4808  if (abs(txyz)>13.) txyz = 13.
4809  ff1 = exp(-txyz*txyz/2.)*afzt(1)
4810  ff1 = ff1/(2.*pi)
4811  fxn = ff1/(ui(j)*ui(j)*sqrt(a1)*a1*sqrt(a2)*sqrt(a3))
4812  fyn = ff1/(ui(j)*ui(j)*sqrt(a1)*a2*sqrt(a2)*sqrt(a3))
4813  fzn = ff1/(ui(j)*ui(j)*sqrt(a1)*a3*sqrt(a2)*sqrt(a3))
4814  ex = ex + wi(j)*fxn*dsq
4815  ey = ey + wi(j)*fyn*dsq
4816  ez = ez + wi(j)*fzn*dsq
4817  end do
4818  ! Field components are in Newton/Coulomb
4819  ex = ex*const*(xc(npt)-xgc)
4820  ey = ey*const*(yc(npt)-ygc)
4821  ez = ez*const*(zc(npt)-zgc)
4822  return
4823  end subroutine intg3
4824  ! *******************************************************************
4825  ! SUBROUTINE compress(pib)
4826  ! PRINT OF PARTICLE COORDINATES
4827  ! *******************************************************************
4828  subroutine compress(pib)
4829  implicit real *8(a-h, o-z)
4830  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4831  common /consta/vl, pi, xmat, rpel, qst
4832  common /faisc/f(10, iptsz), imax, ngood
4833  ! common/etcha1/dav2(maxcell1,33),ichas(iptsz),chasit
4834  ! common/sc3/beamc,scdist,sce10,cplm,ectt,apl,ichaes,iscsp
4835  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4836  ! COMMON/DYN/TREF,VREF
4837  ! common/mcs/imcs,ncstat,cstat(20)
4838  ! common/tapes/in,ifile,meta
4839  ! common/etcha3/ichxyz(iptsz)
4840  ! common/rec/irec
4841  ! common/etcom/cog(8),exten(17),fd(iptsz)
4842  ! logical chasit
4843  ! Do so by shifting particles belonging to the same bunch outside the (+/-) pib window to
4844  ! inside the +/- pib window.
4845  pib = pib*pi/180
4846  do ite = 1, 3
4847  ! Find cog of bunch in time
4848  tcog = 0.
4849  do i = 1, ngood
4850  tcog = tcog + f(6, i)
4851  end do
4852  tcog = tcog/float(ngood)
4853  write (16, 58) tcog*fh*180./pi
4854 58 format (' cog phase before shifting particles: ', e13.7, ' deg')
4855  do i = 1, ngood
4856  drad = (f(6,i)-tcog)*fh
4857  if (drad>pib) then
4858  f(6, i) = (f(6,i)-2.*pi/fh)
4859  end if
4860  if (drad<-pib) then
4861  f(6, i) = (f(6,i)+2.*pi/fh)
4862  end if
4863  end do
4864  end do
4865  ! Find cog of bunch in time after shifting particles
4866  do i = 1, ngood
4867  tcog = tcog + f(6, i)
4868  end do
4869  tcog = tcog/float(ngood)
4870  write (16, 59) tcog*fh*180./pi
4871 59 format (' cog phase after shifting particles : ', e13.7, ' deg')
4872  return
4873  end subroutine compress
4874  ! *******************************************************************
4875  ! SUBROUTINE prbeam(iflg,wfile)
4876  ! PRINT OF PARTICLE COORDINATES
4877  ! *******************************************************************
4878  subroutine prbeam(iflg, wfile)
4879  implicit real *8(a-h, o-z)
4880  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
4881  common /consta/vl, pi, xmat, rpel, qst
4882  common /faisc/f(10, iptsz), imax, ngood
4883  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
4884  common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
4885  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
4886  common /dyn/tref, vref
4887  common /mcs/imcs, ncstat, cstat(20)
4888  common /tapes/in, ifile, meta
4889  common /etcha3/ichxyz(iptsz)
4890  common /rec/irec
4891  common /etcom/cog(8), exten(17), fd(iptsz)
4892  logical chasit
4893  character *80 wfile
4894  ! PRINT OF PARTICLE COORDINATES
4895  ecog = 0.
4896  tcog = 0.
4897  xav = 0.
4898  xpav = 0.
4899  yav = 0.
4900  ypav = 0.
4901  ! **********************************************
4902  ! cog of the bunch
4903  do i = 1, ngood
4904  ecog = ecog + f(7, i)
4905  tcog = tcog + f(6, i)
4906  xav = xav + f(2, i)
4907  xpav = xpav + f(3, i)
4908  yav = yav + f(4, i)
4909  ypav = ypav + f(5, i)
4910  end do
4911  ecog = ecog/float(ngood)
4912  tcog = tcog/float(ngood)
4913  xav = xav/float(ngood)
4914  xpav = xpav/float(ngood)
4915  yav = yav/float(ngood)
4916  ypav = ypav/float(ngood)
4917  ! write particle coordinates to files, phase in radian
4918  beref = vref/vl
4919  gamref = 1./sqrt(1.-(beref*beref))
4920  enref = xmat*gamref
4921  open (58, file=wfile, status='unknown')
4922  if (iflg<100) then
4923  write (58, *) ngood, beamc, fh/(2000000.*pi)
4924  if (chasit) then
4925  write (60, *) ngood, beamc, fh/(2000000.*pi)
4926  write (61, *) ngood, beamc, fh/(2000000.*pi)
4927  end if
4928  else
4929  write (58, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
4930  if (chasit) then
4931  write (60, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
4932  write (61, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
4933  end if
4934  end if
4935  f2 = 0.
4936  f3 = 0.
4937  f4 = 0.
4938  f5 = 0.
4939  do i = 1, ngood
4940  if (irec==2) then
4941  ! coordinates relative to the reference
4942  eprt = f(7, i) - enref
4943  tprt = fh*(f(6,i)-tref)
4944  f2 = f(2, i)
4945  f3 = f(3, i)
4946  f4 = f(4, i)
4947  f5 = f(5, i)
4948  end if
4949  if (irec==1) then
4950  ! absolute values for phase and energy
4951  eprt = f(7, i) - xmat
4952  tprt = fh*(f(6,i)-tcog)
4953  ! **********************************
4954  f2 = f(2, i)
4955  f3 = f(3, i)
4956  f4 = f(4, i)
4957  f5 = f(5, i)
4958  end if
4959  if (irec==0) then
4960  ! values for phase and energy relative to the COG
4961  tprt = fh*(f(6,i)-tcog)
4962  eprt = f(7, i) - ecog
4963  f2 = f(2, i) - xav
4964  f3 = f(3, i) - xpav
4965  f4 = f(4, i) - yav
4966  f5 = f(5, i) - ypav
4967  end if
4968  if (iflg==0 .or. iflg==100) write (58, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
4969  if (iflg==1 .or. iflg==101) write (58, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
4970  if (iflg==2 .or. iflg==102) write (58, 102) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
4971  if (iflg==3 .or. iflg==103) write (58, 103) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i), f(1, i)
4972  if (iflg==10 .or. iflg==110) write (58, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
4973  if (iflg==11 .or. iflg==111) write (58, 101) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
4974  if (iflg==12 .or. iflg==112) write (58, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
4975  if (iflg==13 .or. iflg==113) write (58, 103) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i), f(1, i)
4976  ! ************** only with CHASE, write to file particles removed
4977  if (chasit) then
4978  if (ichxyz(i)==0) then
4979  if (iflg==0 .or. iflg==100) write (60, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
4980  if (iflg==10 .or. iflg==110) write (60, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
4981  if (iflg==1 .or. iflg==101) write (60, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
4982  if (iflg==11 .or. iflg==111) write (60, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
4983  if (iflg==2 .or. iflg==102) write (60, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
4984  if (iflg==12 .or. iflg==112) write (60, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
4985  end if
4986  ! ************** only with CHASE, write to file particles kept
4987  if (ichxyz(i)==1) then
4988  if (iflg==0 .or. iflg==100) write (61, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
4989  if (iflg==10 .or. iflg==110) write (61, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
4990  if (iflg==1 .or. iflg==101) write (61, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
4991  if (iflg==11 .or. iflg==111) write (61, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
4992  if (iflg==2 .or. iflg==102) write (61, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
4993  if (iflg==12 .or. iflg==112) write (61, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
4994  end if
4995  end if
4996  end do
4997  close (58)
4998 100 format (6(e13.6,1x))
4999 101 format (7(e13.6,1x))
5000 102 format (7(e13.6,1x))
5001 103 format (8(e13.6,1x))
5002  return
5003  end subroutine prbeam
5004  ! *******************************************************************
5005  ! SUBROUTINE gausse
5006  ! called by HERSC
5007  ! GAUSS method
5008  ! *******************************************************************
5009  subroutine gausse
5010  implicit real *8(a-h, o-z)
5011  common /gauss1/absg(40), wg(40), igaus
5012  common /randu/ck(15), kmax
5013  dimension ui(40), u9(9), u10(10), u12(12)
5014  dimension w9(9), w10(10), w12(12)
5015  ! GAUSS n=9 de -1. a 1
5016  data (u9(j), j=1, 9)/ -.9681602, -.8360311, -.6133714, -.3242534, 0., .3242534, .6133714, .8360311, .9681602/
5017  data (w9(j), j=1, 9)/.0812744, .1806482, .2606107, .3123471, .3302394, .3123471, .2606107, .1806482, .0812744/
5018  ! GAUSS n=10 de -1. a 1
5019  data (u10(j), j=1, 10)/ -.9739065, -.8650634, -.6794096, -.4333954, -.1488743, .1488743, .4333954, .6794096, &
5020  .8650634, .9739065/
5021  data (w10(j), j=1, 10)/.0666713, .1494513, .2190864, .2692667, .2955242, .2955242, .2692667, .2190864, .1494513, &
5022  .0666713/
5023  ! GAUSS n=12 de -1. a 1
5024  data (u12(j), j=1, 12)/ -.9815606, -.9041173, -.7699027, -.5873180, -.3678315, -.1252334, .1252334, .3678315, &
5025  .5873180, .7699027, .9041173, .9815606/
5026  data (w12(j), j=1, 12)/.0471753, .1069393, .1600783, .2031674, .2334925, .2491470, .2491470, .2334925, .2031674, &
5027  .1600783, .1069393, .0471753/
5028  ! built the abscissas from (-1,1) to (1,0)
5029  if (igaus==9) then
5030  do i = 1, igaus
5031  ui(i) = u9(i)
5032  wg(i) = w9(i)
5033  end do
5034  end if
5035  ! following options in case one wishes to use 10 or 12 steps
5036  if (igaus==10) then
5037  do i = 1, igaus
5038  ui(i) = u10(i)
5039  wg(i) = w10(i)
5040  end do
5041  end if
5042  if (igaus==12) then
5043  do i = 1, igaus
5044  ui(i) = u12(i)
5045  wg(i) = w12(i)
5046  end do
5047  end if
5048  do i = 1, igaus
5049  absg(i) = (1.+ui(i))/2.
5050  wg(i) = wg(i)/2.
5051  end do
5052  return
5053  end subroutine gausse
5054  ! *******************************************************************
5055  ! SUBROUTINE table(lbmax,mbmax,nbmax)
5056  ! called by HERSC
5057  ! arrays of variables independent of the coordinates of particles
5058  ! lbmax,mbmax,nbmax are the maximum degrees of the
5059  ! coefficients A(l,m,n)
5060  ! *******************************************************************
5061  subroutine table(lbmax, mbmax, nbmax)
5062  implicit real *8(a-h, o-z)
5063  common /gauss1/absg(40), wg(40), igaus
5064  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
5065  common /expmod/ragp(40, 100), ragm1(40, 40)
5066  common /randu/ck(15), kmax
5067  common /hass/carg(100), sarg(100), argip(100)
5068  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
5069  common /consta/vl, pi, xmat, rpel, qst
5070  common /factor/fpir(40, 40), fect(30)
5071  ! maximum of subscripts : ideg
5072  ! igaus: order of the Gauss integration ******
5073  ! maximum of lbmax,mmax,nbmax -->ideg
5074  ideg = nbmax
5075  if (lbmax>=ideg) ideg = lbmax
5076  if (mbmax>=ideg) ideg = mbmax
5077  ideg = ideg + 1
5078  idegp2 = ideg + 2
5079  ! arrays of the power of the circular functions fo the Gauss positions absg(i)
5080  ! the maximum power is ideg+2
5081  do i = 1, igaus
5082  co(i, 1) = 1.
5083  sn(i, 1) = 1.
5084  end do
5085  do i = 1, igaus
5086  aco = pi*absg(i)/2.
5087  cod = cos(aco)
5088  snd = sin(aco)
5089  do j = 2, idegp2
5090  co(i, j) = co(i, j-1)*cod
5091  sn(i, j) = sn(i, j-1)*snd
5092  end do
5093  end do
5094  ! arrays used in the integrals of tables 75 and 76
5095  ! absg(i)**2(t1+t2+t3+1)+1-->ragp(i,j) i: Gauss positions, j: is the power
5096  idgp = 3*ideg + kmax
5097  kemax = kmax/2
5098  do i = 1, igaus
5099  ragp(i, 1) = 1.
5100  ragm1(i, 1) = 1.
5101  absm2 = (1.-absg(i))*(1.-absg(i))
5102  do j = 2, idgp
5103  ragp(i, j) = ragp(i, j-1)*absg(i)
5104  end do
5105  ! storage of (absg(i)-1)**2*kemax -->ragm1
5106  do j = 2, kemax + 1
5107  ragm1(i, j) = ragm1(i, j-1)*absm2
5108  end do
5109  end do
5110  do i = 1, idgp + 1
5111  carg(i) = sqrt((4.*float(i-1)+1.)/2.)
5112  sarg(i) = sqrt((4.*float(i-1)+3.)/2.)
5113  argip(i) = sqrt(2.*float(i-1)+1.)
5114  end do
5115  ! store the factorials
5116  do i = 1, 40
5117  do j = 1, i
5118  fpir(i, j) = fper(i-1, j-1)
5119  end do
5120  end do
5121  fj = 1.
5122  fect(1) = 1.
5123  do i = 1, 23
5124  fi = float(i)
5125  fj = fj*fi
5126  fect(i+1) = fj
5127  end do
5128  return
5129  end subroutine table
5130  ! *******************************************************************
5131  ! FUNCTION fpar(i,j)
5132  ! Factorial function called by HERSC
5133  ! *******************************************************************
5134  function fpar(i, j)
5135  implicit real *8(a-h, o-z)
5136  common /factor/fpir(40, 40), fect(30)
5137 
5138  ii = i + 1
5139  jj = j + 1
5140  fpar = fpir(ii, jj)
5141  return
5142  end function fpar
5143  ! *******************************************************************
5144  ! FUNCTION fper(i,j)
5145  ! called by HERSC
5146  ! i*(i-1)*(i-2)*...(i-j+1)/(1.2....j)
5147  ! *******************************************************************
5148  function fper(i, j)
5149  implicit real *8(a-h, o-z)
5150 
5151  faci = 1.
5152  facj = 1.
5153  fper = 1.
5154  if (i==0) return
5155  if (j==0) return
5156  do k = 1, j
5157  facj = facj*float(k)
5158  end do
5159  ii = i
5160  do k = 1, j
5161  faci = faci*float(ii)
5162  ii = ii - 1
5163  end do
5164  fper = faci/facj
5165  return
5166  end function fper
5167  ! *******************************************************************
5168  ! FUNCTION hermint(s,ihd)
5169  ! called by HERSC
5170  ! *******************************************************************
5171  function hermint(s, ihd)
5172  implicit real *8(a-h, o-z)
5173  dimension he(100)
5174 
5175  hermint = 0.
5176  if (ihd==0) then
5177  hermint = 1.
5178  return
5179  end if
5180  if (ihd==1) then
5181  hermint = s
5182  return
5183  end if
5184  he(1) = 1.
5185  he(2) = s
5186  m1 = ihd - 1
5187  do k = 1, m1
5188  he(k+2) = s*he(k+1) - float(k)*he(k)
5189  end do
5190  hermint = he(ihd+1)*exp(-s*s/2.)
5191  return
5192  end function hermint
5193  ! *******************************************************************
5194  ! FUNCTION fact(m)
5195  ! FACTORIAL of M
5196  ! *******************************************************************
5197  function fact(m)
5198  implicit real *8(a-h, o-z)
5199 
5200  fact = 1.
5201  if (m==0) return
5202  do k = 1, m
5203  fact = fact*float(k)
5204  end do
5205  return
5206  end function fact
5207  ! *******************************************************************
5208  ! FUNCTION factd(m)
5209  ! Calculate of (-1)**m *(2m-1)!!
5210  ! *******************************************************************
5211  function factd(m)
5212  implicit real *8(a-h, o-z)
5213  dimension he(100)
5214 
5215  factd = 1.
5216  if (m==0) factd = 1.
5217  if (m==1) then
5218  factd = -1.
5219  return
5220  end if
5221  he(1) = 1.
5222  do k = 1, 2*m - 1, 2
5223  he(k+2) = -float(k)*he(k)
5224  end do
5225  factd = he(2*m+1)
5226  continue
5227  return
5228  end function factd
5229  ! *******************************************************************
5230  ! SUBROUTINE bhdist
5231  ! called by HERSC
5232  ! computes: the coefficients A(l,m,n)
5233  ! the rms sizes in x, y and z-direction
5234  ! selects: the significants terms in the Hermite series expansion
5235  ! lmax, mmax and nmax are the maximum values of l, m, n for these
5236  ! coefficients
5237  ! *******************************************************************
5238  subroutine bhdist
5239  implicit real *8(a-h, o-z)
5240  common /coef/a(30, 30, 30), xa, xb, xc
5241  common /ind/lmax, mmax, nmax
5242  common /indin/lmaxi, mmaxi, nmaxxi
5243  common /hcgrms/xcdg, ycdg, zcdg, ect, eps
5244  ! character iitime*30
5245  ! hermite degrees
5246  lmax = lmaxi
5247  mmax = mmaxi
5248  nmax = nmaxxi
5249  ect = 4.
5250  ! call mytime(iitime)
5251  ! write(16,*) 'PINTFAST started at ',iitime
5252  call pintfast
5253  ! call mytime(iitime)
5254  ! write(16,*) 'PINTFAST end, HCOEF started at ',iitime
5255  call hcoef
5256  ! call mytime(iitime)
5257  ! write(16,*) 'HCOEF ended at ',iitime
5258  return
5259  end subroutine bhdist
5260  ! *******************************************************************
5261  ! SUBROUTINE trms(isucc)
5262  ! called by HERSC
5263  ! storage of the variables depending only of the rms sizes
5264  ! lmax,mmax,nmax : maximum of the subscripts: l,m,n
5265  ! for the significants Almn
5266  ! isucc:order of succession of the integrals in table 1-b
5267  ! isucc=1: order of succesion x-->y-->z
5268  ! isucc=2: order of succesion y-->z-->x
5269  ! isucc=3: order of succesion z-->x-->y
5270  ! *******************************************************************
5271  subroutine trms(isucc)
5272  implicit real *8(a-h, o-z)
5273  common /consta/vl, pi, xmat, rpel, qst
5274  common /coef/a(30, 30, 30), xa, xb, xc
5275  common /ind/lmax, mmax, nmax
5276  ! lmax,mmax,nmax from zero
5277  common /rms/rms(3, 50), s1, s2, s3
5278  common /gauss1/absg(40), wg(40), igaus
5279  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
5280  common /randu/ck(15), kmax
5281  ! minimum of the rms sizes xa,xb,xc
5282  rmin = xa
5283  if (rmin>xb) rmin = xb
5284  if (rmin>xc) rmin = xc
5285  ! order of the succession of the integrals
5286  if (rmin==xc) isucc = 3
5287  if (rmin==xb) isucc = 2
5288  if (rmin==xa) isucc = 1
5289  ! maximum of lmax,mmax,nmax
5290  maxi = lmax
5291  if (maxi<mmax) maxi = mmax
5292  if (maxi<nmax) maxi = nmax
5293  maxt = 2*(maxi+1) + 3
5294  x3 = 0.
5295  x2 = 0.
5296  x1 = 0.
5297  ! order of succession x->y->z
5298  if (isucc==1) then
5299  x3 = xa
5300  x2 = xb
5301  x1 = xc
5302  end if
5303  ! order of succession y->z->x
5304  if (isucc==2) then
5305  x3 = xb
5306  x2 = xc
5307  x1 = xa
5308  end if
5309  ! order of succession z->x->y
5310  if (isucc==3) then
5311  x3 = xc
5312  x2 = xa
5313  x1 = xb
5314  end if
5315  ! array rms(j,i) Powers of the rms sizes j=1,2,3, the value i is the power
5316  rms(3, 1) = 1.
5317  rms(2, 1) = 1.
5318  rms(1, 1) = 1.
5319  do i = 2, maxt
5320  rms(3, i) = rms(3, i-1)*x3
5321  rms(2, i) = rms(2, i-1)*x2
5322  rms(1, i) = rms(1, i-1)*x1
5323  end do
5324  j1 = kmax/2
5325  i1m = (lmax+1)/2
5326  i2m = (mmax+1)/2
5327  i3m = (nmax+1)/2
5328  im = i1m + i2m + i3m + j1 + 4
5329  if (im>=40) then
5330  write (16, *) ' overlap the array blam with im= ', im
5331  stop
5332  end if
5333  do i = 1, igaus
5334  blam(i, 1) = (rms(1,3)*co(i,3)+rms(2,3)*sn(i,3))/rms(3, 3)
5335  do ii = 2, im
5336  blam(i, ii) = blam(i, ii-1)*blam(i, 1)
5337  end do
5338  end do
5339  return
5340  end subroutine trms
5341  ! *******************************************************************
5342  ! SUBROUTINE uvrms
5343  ! called by HERSC
5344  ! storage of the variables depending only of the coordinate s3
5345  ! *******************************************************************
5346  subroutine uvrms
5347  implicit real *8(a-h, o-z)
5348  common /consta/vl, pi, xmat, rpel, qst
5349  common /rms/rms(3, 50), s1, s2, s3
5350  common /gauss1/absg(40), wg(40), igaus
5351  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
5352  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
5353  common /expmod/ragp(40, 100), ragm1(40, 40)
5354  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
5355  common /ind/lmax, mmax, nmax
5356  common /indttal/lmnt
5357  common /randu/ck(15), kmax
5358  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
5359  ! pi2=pi*pi, sqpi=(pi/2)**3/2
5360  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
5361  common /herfun/hs1(60), hs2(60), hs3(60)
5362 
5363  s32 = s3*s3
5364  s22 = s2*s2
5365  s12 = s1*s1
5366  exs3 = exp(-s32/2.)
5367  exs2 = exp(-s22/2.)
5368  exs1 = exp(-s12/2.)
5369  as3 = abs(s3)
5370  sgns3 = 1.
5371  if (s3<0.) sgns3 = -1.
5372  as31 = as3*s1
5373  as32 = as3*s2
5374  s1rms = s1*rms(1, 2)
5375  s2rms = s2*rms(2, 2)
5376  ! power of as3, used in the functions spii,......
5377  s3pw(1) = 1.
5378  do i = 2, kmax
5379  s3pw(i) = s3pw(i-1)*as3
5380  end do
5381  ! memory array hsint(ig,arg,indice) for functions sipp,...
5382  do ig = 1, igaus
5383  wgpi = wg(ig)*pi/2.
5384  sqblam(ig) = sqrt(blam(ig,1))
5385  xlblam = sqblam(ig)*rms(3, 2)
5386  do iarg = 1, 2
5387  arghm1 = s1rms*co(ig, 2)/xlblam
5388  arghm2 = s2rms*sn(ig, 2)/xlblam
5389  if (iarg==1) then
5390  arg = arghm1 + arghm2
5391  earg = exp(-arg*arg/2.)
5392  end if
5393  if (iarg==2) then
5394  arg = arghm1 - arghm2
5395  earg = exp(-arg*arg/2.)
5396  end if
5397  hsint(ig, iarg, 1) = 1.*earg*wgpi
5398  hsint(ig, iarg, 2) = arg*earg*wgpi
5399  do inhs = 3, lmnt
5400  hsint(ig, iarg, inhs) = arg*hsint(ig, iarg, inhs-1) - float(inhs-2)*hsint(ig, iarg, inhs-2)
5401  end do
5402  end do
5403  end do
5404  r13 = rms(1, 2)/rms(3, 2)
5405  r23 = rms(2, 2)/rms(3, 2)
5406  do j = 1, igaus
5407  do i = 1, igaus
5408  aeps1 = ragp(i, 3)*(blam(j,1)-1.)/2.
5409  aeps1 = s32*(aeps1+ragp(i,2))
5410  aeps2 = ragp(i, 3)*blam(j, 1)/2.
5411  aeps2 = aeps2*s32
5412  akc1 = ragp(i, 2)*r13*co(j, 2)*as31
5413  akc2 = ragp(i, 2)*r23*sn(j, 2)*as32
5414  aks1 = ragp(i, 2)*r13*co(j, 2)*as31
5415  aks2 = ragp(i, 2)*r23*sn(j, 2)*as32
5416  epsi1(i, j) = exp(-aeps1)*wg(i)
5417  epsi2(i, j) = exp(-aeps2)*wg(i)
5418  akpcc(i, j) = cos(akc1)*cos(akc2)
5419  akpcs(i, j) = cos(akc1)*sin(akc2)
5420  akpsc(i, j) = sin(akc1)*cos(akc2)
5421  akpss(i, j) = sin(akc1)*sin(akc2)
5422  end do
5423  end do
5424  ! Hermite functions
5425  hs1(1) = exs1
5426  hs2(1) = exs2
5427  hs3(1) = exs3
5428  hs1(2) = s1*exs1
5429  hs2(2) = s2*exs2
5430  hs3(2) = s3*exs3
5431  do ihe = 3, lmnt
5432  hs1(ihe) = s1*hs1(ihe-1) - float(ihe-2)*hs1(ihe-2)
5433  hs2(ihe) = s2*hs2(ihe-1) - float(ihe-2)*hs2(ihe-2)
5434  hs3(ihe) = s3*hs3(ihe-1) - float(ihe-2)*hs3(ihe-2)
5435  end do
5436  return
5437  end subroutine uvrms
5438  ! *******************************************************************
5439  ! SUBROUTINE fielde(lc,mc,nc,isucc)
5440  ! beam self-fields computation called by HERSC
5441  ! look for the parity of the currents lc,mc and nc
5442  ! compute the corresponding field components
5443  ! isucc=1: a<b,c
5444  ! isucc=2: b<a,c
5445  ! isucc=3: c<a,b
5446  ! x,y,z are the scaling coordinates: x/a,y/b,z/c
5447  ! The corresponding analytical equations are in the number of the
5448  ! tables. The table number in 'comments' refers to the corresponding
5449  ! analytical equations
5450  ! *******************************************************************
5451  subroutine fielde(lc, mc, nc, isucc)
5452  implicit real *8(a-h, o-z)
5453  common /rms/rms(3, 50), s1, s2, s3
5454  common /partcl/x, y, z
5455  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
5456  common /field/ex, ey, ez
5457  common /randu/ck(15), kmax
5458  ! pi2=pi*pi, sqpi=(pi/2)**3/2
5459  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
5460  ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
5461  ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3))
5462  common /sgpth/mksgi, mksgp
5463  common /ftth/makti, maktp
5464  common /fsth/maksi, maksp
5465  logical maksi, maksp
5466  logical makti, maktp
5467  logical mksgi, mksgp
5468  logical lpl, lpm, lpn
5469  ! look for the parity of the currents lc,mc,nc
5470  lpl = .false.
5471  lpm = .false.
5472  lpn = .false.
5473  makti = .false.
5474  maktp = .false.
5475  maksi = .false.
5476  maksp = .false.
5477  mksgi = .false.
5478  mksgp = .false.
5479  xlc = lc
5480  tl = xlc - 2.*int(xlc/2.+0.0001)
5481  if (tl==0.) lpl = .true.
5482  xmc = mc
5483  tm = xmc - 2.*int(xmc/2.+0.0001)
5484  if (tm==0.) lpm = .true.
5485  xnc = nc
5486  tn = xnc - 2.*int(xnc/2.+0.0001)
5487  if (tn==0.) lpn = .true.
5488  if (lpl .and. lpm .and. lpn) itpar = 1
5489  if (lpl .and. lpm .and. .not. lpn) itpar = 2
5490  if (lpl .and. .not. lpm .and. lpn) itpar = 3
5491  if (lpl .and. .not. lpm .and. .not. lpn) itpar = 4
5492  if (.not. lpl .and. lpm .and. lpn) itpar = 5
5493  if (.not. lpl .and. lpm .and. .not. lpn) itpar = 6
5494  if (.not. lpl .and. .not. lpm .and. lpn) itpar = 7
5495  if (.not. lpl .and. .not. lpm .and. .not. lpn) itpar = 8
5496 
5497  ! values of the variables it1,it2,it3 in relation with lc,mc,nc
5498  ! the initial values of these lc,mc,nc is zero
5499  if (isucc==1) then
5500  ! a<b,c
5501  if (itpar==1) then
5502  ! E E E and a<b,c:
5503  ! table 67-a: Ex=E(2t3+1,2t2,2t1)
5504  ! Ey=E(2t3,2t2+1,2t1)
5505  ! Ez=E(2t3,2t2,2t1+1)
5506  ! values of it1,it2,it3 in table 3-a
5507  it3 = lc/2
5508  it2 = mc/2
5509  it1 = nc/2
5510  if (s3/=0.) then
5511  ! it=2*(it1+it2+it3)+1
5512  it = lc + mc + nc + 1
5513  pwas3 = as3**it
5514  end if
5515  ex = eipp(it1, it2, it3)
5516  ey = epip(it1, it2, it3)
5517  ez = eppi(it1, it2, it3)
5518  return
5519  end if
5520  if (itpar==2) then
5521  ! E E I and a<b,c
5522  ! table 67-g: Ex=E(2t3+1,2t2,2t1+1)
5523  ! Ey=E(2t3,2t2+1,2t1+1)
5524  ! Ez=E(2t3,2t2,2t1)
5525  ! values of it1,it2,it3 in table 3-g
5526  ! x-direction and y-direction
5527  it3 = lc/2
5528  it2 = mc/2
5529  it1 = (nc-1)/2
5530  if (s3/=0.) then
5531  ! it=2*(it1+it2+it3)+1
5532  it = lc + mc + nc
5533  pwas3 = as3**it
5534  end if
5535  ex = eipi(it1, it2, it3)
5536  ey = epii(it1, it2, it3)
5537  ! z-direction
5538  it1 = (nc+1)/2
5539  if (s3/=0.) pwas3 = pwas3*s32
5540  ! it=2*(it1+it2+it3)+1
5541  ez = eppp(it1, it2, it3)
5542  return
5543  end if
5544  if (itpar==3) then
5545  ! E I E and a<b,c
5546  ! in table 67-h: Ex=E(2t3+1,2t2+1,2t1)
5547  ! Ey=E(2t3,2t2,2t1)
5548  ! Ez=E(2t3,2t2+1,2t1+1)
5549  ! values of it1,it2,it3 in table 3-h
5550  ! x-direction
5551  it3 = lc/2
5552  it2 = (mc-1)/2
5553  it1 = nc/2
5554  if (s3/=0.) then
5555  ! it=2*(it1+it2+it3)+1
5556  it = lc + mc + nc
5557  apwas3 = as3**it
5558  pwas3 = apwas3
5559  end if
5560  ex = eiip(it1, it2, it3)
5561  ! y-direction
5562  it3 = lc/2
5563  it2 = (mc+1)/2
5564  it1 = nc/2
5565  ! it=2*(it1+it2+it3)+1
5566  if (s3/=0.) pwas3 = pwas3*s32
5567  ey = eppp(it1, it2, it3)
5568  ! z-direction
5569  it3 = lc/2
5570  it2 = (mc-1)/2
5571  it1 = nc/2
5572  if (s3/=0.) pwas3 = apwas3
5573  ! it=2*(it1+it2+it3)+1
5574  ez = epii(it1, it2, it3)
5575  return
5576  end if
5577  if (itpar==4) then
5578  ! E I I and a<b,c
5579  ! in table 67-f: Ex=E(2t3+1,2t2+1,2t1+1)
5580  ! Ey=E(2t3,2t2,2t1+1)
5581  ! Ez=E(2t3,2t2+1,2t1)
5582  ! values of it1,it2,it3 in table 3-f
5583  ! x-direction
5584  it3 = lc/2
5585  it2 = (mc-1)/2
5586  it1 = (nc-1)/2
5587  if (s3/=0.) then
5588  ! it=2*(it1+it2+it3)+1
5589  it = lc + mc + nc - 1
5590  pwas3 = as3**it
5591  end if
5592  ex = eiii(it1, it2, it3)
5593  ! y-direction
5594  it3 = lc/2
5595  it2 = (mc+1)/2
5596  it1 = (nc-1)/2
5597  ! it=2*(it1+it2+it3)+1
5598  if (s3/=0.) pwas3 = pwas3*s32
5599  ey = eppi(it1, it2, it3)
5600  ! z-direction
5601  it3 = lc/2
5602  it2 = (mc-1)/2
5603  it1 = (nc+1)/2
5604  ez = epip(it1, it2, it3)
5605  return
5606  end if
5607  if (itpar==5) then
5608  ! I E E and a<b,c
5609  ! in table 67-c: Ex=E(2t3,2t2,2t1)
5610  ! Ey=E(2t3+1,2t2+1,2t1)
5611  ! Ez=E(2t3+1,2t2,2t1+1)
5612  ! values of it1,it2,it3 in table 3-c
5613  ! x-direction
5614  it3 = (lc+1)/2
5615  it2 = mc/2
5616  it1 = nc/2
5617  if (s3/=0.) then
5618  ! it=2*(it1+it2+it3)+1
5619  it = lc + mc + nc
5620  apwas3 = as3**it
5621  pwas3 = apwas3*s32
5622  end if
5623  ex = eppp(it1, it2, it3)
5624  ! y-direction
5625  it3 = (lc-1)/2
5626  it2 = mc/2
5627  it1 = nc/2
5628  if (s3/=0.) then
5629  ! it=2*(it1+it2+it3)+1
5630  pwas3 = apwas3
5631  pw3as3 = apwas3
5632  end if
5633  ey = eiip(it1, it2, it3)
5634  ! z-direction
5635  it3 = (lc-1)/2
5636  it2 = mc/2
5637  it1 = nc/2
5638  ez = eipi(it1, it2, it3)
5639  return
5640  end if
5641  if (itpar==6) then
5642  ! I E I and a<b,c
5643  ! in table 67-e: Ex=E(2t3,2t2,2t1+1)
5644  ! Ey=E(2t3+1,2t2+1,2t1+1)
5645  ! Ez=E(2t3+1,2t2,2t1)
5646  ! values of it1,it2,it3 in table 3-e
5647  ! x-direction
5648  it3 = (lc+1)/2
5649  it2 = mc/2
5650  it1 = (nc-1)/2
5651  if (s3/=0.) then
5652  ! it=2*(it1+it2+it3)+1
5653  it = lc + mc + nc - 1
5654  apwas3 = as3**it
5655  pwas3 = apwas3*s32
5656  end if
5657  ex = eppi(it1, it2, it3)
5658  ! y-direction
5659  it3 = (lc-1)/2
5660  it2 = mc/2
5661  it1 = (nc-1)/2
5662  if (s3/=0.) then
5663  ! it=2*(it1+it2+it3)+1
5664  pwas3 = apwas3
5665  end if
5666  ey = eiii(it1, it2, it3)
5667  ! z-direction
5668  it3 = (lc-1)/2
5669  it2 = mc/2
5670  it1 = (nc+1)/2
5671  ! it=2*(it1+it2+it3)+1
5672  if (s3/=0.) pwas3 = pwas3*s32
5673  ez = eipp(it1, it2, it3)
5674  return
5675  end if
5676  if (itpar==7) then
5677  ! I I E and a<b,c
5678  ! in table 67-d: Ex=E(2t3,2t2+1,2t1)
5679  ! Ey=E(2t3+1,2t2,2t1)
5680  ! Ez=E(2t3+1,2t2+1,2t1+1)
5681  ! values of it1,it2,it3 in table 3-d
5682  ! x-direction
5683  it3 = (lc+1)/2
5684  it2 = (mc-1)/2
5685  it1 = nc/2
5686  if (s3/=0.) then
5687  ! it=2*(it1+it2+it3)+1
5688  it = lc + mc + nc - 1
5689  apwas3 = as3**it
5690  pwas3 = apwas3*s32
5691  end if
5692  ex = epip(it1, it2, it3)
5693  ! y-direction
5694  it3 = (lc-1)/2
5695  it2 = (mc+1)/2
5696  it1 = nc/2
5697  ! it=2*(it1+it2+it3)+1
5698  ey = eipp(it1, it2, it3)
5699  ! z-direction
5700  it3 = (lc-1)/2
5701  it2 = (mc-1)/2
5702  it1 = nc/2
5703  ! it=2*(it1+it2+it3)+1
5704  if (s3/=0.) pwas3 = apwas3
5705  ez = eiii(it1, it2, it3)
5706  return
5707  end if
5708  if (itpar==8) then
5709  ! I I I and a<b,c
5710  ! in table 67-b: Ex=E(2t3,2t2+1,2t1+1)
5711  ! Ey=E(2t3+1,2t2,2t1+1)
5712  ! Ez=E(2t3+1,2t2+1,2t1)
5713  ! values of it1,it2,it3 in table 3-b
5714  ! x-direction
5715  it3 = (lc+1)/2
5716  it2 = (mc-1)/2
5717  it1 = (nc-1)/2
5718  if (s3/=0.) then
5719  ! it=2*(it1+it2+it3)+1
5720  it = lc + mc + nc
5721  pwas3 = as3**it
5722  end if
5723  ex = epii(it1, it2, it3)
5724  ! y-direction
5725  it3 = (lc-1)/2
5726  it2 = (mc+1)/2
5727  it1 = (nc-1)/2
5728  ! it=2*(it1+it2+it3)+1
5729  ey = eipi(it1, it2, it3)
5730  ! z-direction
5731  it3 = (lc-1)/2
5732  it2 = (mc-1)/2
5733  it1 = (nc+1)/2
5734  ez = eiip(it1, it2, it3)
5735  return
5736  end if
5737  ! endif of isucc=1----> a<b,c
5738  end if
5739  if (isucc==2) then
5740  ! b<a,c
5741  if (itpar==1) then
5742  ! E E E and b<a,c
5743  ! table 67-a: Ex=E(2t3,2t2,2t1+1)
5744  ! Ey=E(2t3+1,2t2,2t1)
5745  ! Ez=E(2t3,2t2+1,2t1)
5746  ! values of it1,it2,it3 in table 3-a
5747  it3 = mc/2
5748  it2 = nc/2
5749  it1 = lc/2
5750  if (s3/=0.) then
5751  ! it=2*(it1+it2+it3)+1
5752  it = mc + nc + lc + 1
5753  pwas3 = as3**it
5754  end if
5755  ex = eppi(it1, it2, it3)
5756  ey = eipp(it1, it2, it3)
5757  ez = epip(it1, it2, it3)
5758  return
5759  end if
5760  if (itpar==2) then
5761  ! E E I and b<a,c
5762  ! table 67-h: Ex=E(2t3,2t2+1,2t1+1)
5763  ! Ey=E(2t3+1,2t2+1,2t1)
5764  ! Ez=E(2t3,2t2,2t1)
5765  ! values of it1,it2,it3 in table 3-h
5766  ! x-direction and y-direction
5767  it3 = mc/2
5768  it2 = (nc-1)/2
5769  it1 = lc/2
5770  if (s3/=0) then
5771  ! it=2*(it1+it2+it3)+1
5772  it = mc + nc + lc
5773  pwas3 = as3**it
5774  end if
5775  ex = epii(it1, it2, it3)
5776  ey = eiip(it1, it2, it3)
5777  ! z-direction
5778  it2 = (nc+1)/2
5779  ! it=2*(it1+it2+it3)+1
5780  if (s3/=0.) pwas3 = pwas3*s32
5781  ez = eppp(it1, it2, it3)
5782  return
5783  end if
5784  if (itpar==3) then
5785  ! E I E and b<a,c
5786  ! in table 67-c: Ex=E(2t3+1,2t2,2t1+1)
5787  ! Ey=E(2t3,2t2,2t1)
5788  ! Ez=E(2t3+1,2t2+1,2t1)
5789  ! values of it1,it2,it3 in table 3-c
5790  ! x-direction
5791  it3 = (mc-1)/2
5792  it2 = nc/2
5793  it1 = lc/2
5794  if (s3/=0.) then
5795  ! it=2*(it1+it2+it3)+1
5796  it = mc + nc + lc
5797  apwas3 = as3**it
5798  pwas3 = apwas3
5799  end if
5800  ex = eipi(it1, it2, it3)
5801  ! y-direction
5802  it3 = (mc+1)/2
5803  it2 = nc/2
5804  it1 = lc/2
5805  if (s3/=0.) then
5806  ! it=2*(it1+it2+it3)+1
5807  pwas3 = pwas3*s32
5808  end if
5809  ey = eppp(it1, it2, it3)
5810  ! z-direction
5811  it3 = (mc-1)/2
5812  it2 = nc/2
5813  it1 = lc/2
5814  if (s3/=0.) pwas3 = apwas3
5815  ez = eiip(it1, it2, it3)
5816  return
5817  end if
5818  if (itpar==4) then
5819  ! E I I and b<a,c
5820  ! in table 67-d: Ex=E(2t3+1,2t2+1,2t1+1)
5821  ! Ey=E(2t3,2t2+1,2t1)
5822  ! Ez=E(2t3+1,2t2,2t1)
5823  ! values of it1,it2,it3 in table 3-d
5824  ! x-direction
5825  it3 = (mc-1)/2
5826  it2 = (nc-1)/2
5827  it1 = lc/2
5828  if (s3/=0.) then
5829  ! it=2*(it1+it2+it3)+1
5830  it = mc + nc + lc - 1
5831  pwas3 = as3**it
5832  end if
5833  ex = eiii(it1, it2, it3)
5834  ! y-direction
5835  it3 = (mc+1)/2
5836  it2 = (nc-1)/2
5837  it1 = lc/2
5838  ! it=2*(it1+it2+it3)+1
5839  if (s3/=0.) then
5840  pwas3 = pwas3*s32
5841  end if
5842  ey = epip(it1, it2, it3)
5843  ! z-direction
5844  it3 = (mc-1)/2
5845  it2 = (nc+1)/2
5846  it1 = lc/2
5847  ! it=2*(it1+it2+it3)+1
5848  ez = eipp(it1, it2, it3)
5849  return
5850  end if
5851  if (itpar==5) then
5852  ! I E E and b<a,c
5853  ! in table 67-g: Ex=E(2t3,2t2,2t1)
5854  ! Ey=E(2t3+1,2t2,2t1+1)
5855  ! Ez=E(2t3,2t2+1,2t1+1)
5856  ! values of it1,it2,it3 in table 3-g
5857  ! x-direction
5858  it3 = mc/2
5859  it2 = nc/2
5860  it1 = (lc+1)/2
5861  if (s3/=0.) then
5862  ! it=2*(it1+it2+it3)+1
5863  it = mc + nc + lc
5864  apwas3 = as3**it
5865  pwas3 = apwas3*s32
5866  end if
5867  ex = eppp(it1, it2, it3)
5868  ! y-direction
5869  it3 = mc/2
5870  it2 = nc/2
5871  it1 = (lc-1)/2
5872  ! it=2*(it1+it2+it3)+1
5873  if (s3/=0.) pwas3 = apwas3
5874  ey = eipi(it1, it2, it3)
5875  ! z-direction
5876  it3 = mc/2
5877  it2 = nc/2
5878  it1 = (lc-1)/2
5879  ez = epii(it1, it2, it3)
5880  return
5881  end if
5882  if (itpar==6) then
5883  ! I E I and b<a,c
5884  ! in table 67-f: Ex=E(2t3,2t2+1,2t1)
5885  ! Ey=E(2t3+1,2t2+1,2t1+1)
5886  ! Ez=E(2t3,2t2,2t1+1)
5887  ! values of it1,it2,it3 in table 3-f
5888  ! x-direction
5889  it3 = mc/2
5890  it2 = (nc-1)/2
5891  it1 = (lc+1)/2
5892  if (s3/=0.) then
5893  ! it=2*(it1+it2+it3)+1
5894  it = mc + nc + lc - 1
5895  apwas3 = as3**it
5896  pwas3 = apwas3*s32
5897  end if
5898  ex = epip(it1, it2, it3)
5899  ! y-direction
5900  it3 = mc/2
5901  it2 = (nc-1)/2
5902  it1 = (lc-1)/2
5903  ! it=2*(it1+it2+it3)+1
5904  if (s3/=0.) pwas3 = apwas3
5905  ey = eiii(it1, it2, it3)
5906  ! z-direction
5907  it3 = mc/2
5908  it2 = (nc+1)/2
5909  it1 = (lc-1)/2
5910  ! it=2*(it1+it2+it3)+1
5911  if (s3/=0.) pwas3 = apwas3*s32
5912  ez = eppi(it1, it2, it3)
5913  return
5914  end if
5915  if (itpar==7) then
5916  ! I I E and b<a,c
5917  ! in table 66-e: Ex=E(2t3+1,2t2,2t1)
5918  ! Ey=E(2t3,2t2,2t1+1)
5919  ! Ez=E(2t3+1,2t2+1,2t1+1)
5920  ! values of it1,it2,it3 in table 3-e
5921  ! x-direction
5922  it3 = (mc-1)/2
5923  it2 = nc/2
5924  it1 = (lc+1)/2
5925  if (s3/=0.) then
5926  ! it=2*(it1+it2+it3)+1
5927  it = mc + nc + lc - 1
5928  apwas3 = as3**it
5929  pwas3 = apwas3*s32
5930  end if
5931  ex = eipp(it1, it2, it3)
5932  ! y-direction
5933  it3 = (mc+1)/2
5934  it2 = nc/2
5935  it1 = (lc-1)/2
5936  ! it=2*(it1+it2+it3)+1
5937  ey = eppi(it1, it2, it3)
5938  ! z-direction
5939  it3 = (mc-1)/2
5940  it2 = nc/2
5941  it1 = (lc-1)/2
5942  if (s3/=0.) pwas3 = apwas3
5943  ! it=2*(it1+it2+it3)+1
5944  ez = eiii(it1, it2, it3)
5945  return
5946  end if
5947  if (itpar==8) then
5948  ! I I I and b<a,c
5949  ! in table 67-b: Ex=E(2t3+1,2t2+1,2t1)
5950  ! Ey=E(2t3,2t2+1,2t1+1)
5951  ! Ez=E(2t3+1,2t2,2t1+1)
5952  ! values of it1,it2,it3 in table 3-b
5953  ! x-direction
5954  it3 = (mc-1)/2
5955  it2 = (nc-1)/2
5956  it1 = (lc+1)/2
5957  if (s3/=0.) then
5958  ! it=2*(it1+it2+it3)+1
5959  it = mc + nc + lc
5960  pwas3 = as3**it
5961  end if
5962  ex = eiip(it1, it2, it3)
5963  ! y-direction
5964  it3 = (mc+1)/2
5965  it2 = (nc-1)/2
5966  it1 = (lc-1)/2
5967  ! it=2*(it1+it2+it3)+1
5968  ey = epii(it1, it2, it3)
5969  ! z-direction
5970  it3 = (mc-1)/2
5971  it2 = (nc+1)/2
5972  it1 = (lc-1)/2
5973  ! it=2*(it1+it2+it3)+1
5974  ez = eipi(it1, it2, it3)
5975  return
5976  end if
5977  ! endif of isucc=2----> b<a,c
5978  end if
5979  if (isucc==3) then
5980  ! c<a,b
5981  if (itpar==1) then
5982  ! E E E and c<a,b
5983  ! table 67-a: Ex=E(2t3,2t2+1,2t1)
5984  ! Ey=E(2t3,2t2,2t1+1)
5985  ! Ez=E(2t3+1,2t2,2t1)
5986  ! values of it1,it2,it3 in table 3-a
5987  it3 = nc/2
5988  it2 = lc/2
5989  it1 = mc/2
5990  if (s3/=0.) then
5991  ! it=2*(it1+it2+it3)+1
5992  it = nc + lc + mc + 1
5993  pwas3 = as3**it
5994  end if
5995  ex = epip(it1, it2, it3)
5996  ey = eppi(it1, it2, it3)
5997  ez = eipp(it1, it2, it3)
5998  return
5999  end if
6000  if (itpar==2) then
6001  ! E E I and c<a,b
6002  ! table 67-c: Ex=E(2t3+1,2t2+1,2t1)
6003  ! Ey=E(2t3+1,2t2,2t1+1)
6004  ! Ez=E(2t3,2t2,2t1)
6005  ! values of it1,it2,it3 in table 3-c
6006  ! x-direction and y-direction
6007  it3 = (nc-1)/2
6008  it2 = lc/2
6009  it1 = mc/2
6010  if (s3/=0.) then
6011  ! it=2*(it1+it2+it3)+1
6012  it = nc + lc + mc
6013  pwas3 = as3**it
6014  end if
6015  ex = eiip(it1, it2, it3)
6016  ey = eipi(it1, it2, it3)
6017  ! z-direction
6018  it3 = (nc+1)/2
6019  if (s3/=0.) pwas3 = pwas3*s32
6020  ! it=2*(it1+it2+it3)+1
6021  ez = eppp(it1, it2, it3)
6022  return
6023  end if
6024  if (itpar==3) then
6025  ! E I E and c<a,b
6026  ! in table 67-g: Ex=E(2t3,2t2+1,2t1+1)
6027  ! Ey=E(2t3,2t2,2t1)
6028  ! Ez=E(2t3+1,2t2,2t1+1)
6029  ! values of it1,it2,it3 in table 3-g
6030  ! x-direction
6031  it3 = nc/2
6032  it2 = lc/2
6033  it1 = (mc-1)/2
6034  if (s3/=0.) then
6035  ! it=2*(it1+it2+it3)+1
6036  it = nc + lc + mc
6037  apwas3 = as3**it
6038  pwas3 = apwas3
6039  end if
6040  ex = epii(it1, it2, it3)
6041  ! y-direction
6042  it3 = nc/2
6043  it2 = lc/2
6044  it1 = (mc+1)/2
6045  ! it=2*(it1+it2+it3)+1
6046  if (s3/=0.) pwas3 = pwas3*s32
6047  ey = eppp(it1, it2, it3)
6048  ! z-direction
6049  it3 = nc/2
6050  it2 = lc/2
6051  it1 = (mc-1)/2
6052  if (s3/=0.) pwas3 = apwas3
6053  ez = eipi(it1, it2, it3)
6054  return
6055  end if
6056  if (itpar==4) then
6057  ! E I I and c<a,b
6058  ! in table 67-e: Ex=E(2t3+1,2t2+1,2t1+1)
6059  ! Ey=E(2t3+1,2t2,2t1)
6060  ! Ez=E(2t3,2t2,2t1+1)
6061  ! values of it1,it2,it3 in table 3-e
6062  ! x-direction
6063  it3 = (nc-1)/2
6064  it2 = lc/2
6065  it1 = (mc-1)/2
6066  if (s3/=0.) then
6067  ! it=2*(it1+it2+it3)+1
6068  it = nc + lc + mc - 1
6069  pwas3 = as3**it
6070  end if
6071  ex = eiii(it1, it2, it3)
6072  ! y-direction
6073  it3 = (nc-1)/2
6074  it2 = lc/2
6075  it1 = (mc+1)/2
6076  ! it=2*(it1+it2+it3)+1
6077  if (s3/=0.) pwas3 = pwas3*s32
6078  ey = eipp(it1, it2, it3)
6079  ! z-direction
6080  it3 = (nc+1)/2
6081  it2 = lc/2
6082  it1 = (mc-1)/2
6083  ! it=2*(it1+it2+it3)+1
6084  ez = eppi(it1, it2, it3)
6085  return
6086  end if
6087  if (itpar==5) then
6088  ! I E E and c<a,b
6089  ! in table 67-h: Ex=E(2t3,2t2,2t1)
6090  ! Ey=E(2t3,2t2+1,2t1+1)
6091  ! Ez=E(2t3+1,2t2+1,2t1)
6092  ! values of it1,it2,it3 in table 3-h
6093  ! x-direction
6094  it3 = nc/2
6095  it2 = (lc+1)/2
6096  it1 = mc/2
6097  if (s3/=0.) then
6098  ! it=2*(it1+it2+it3)+1
6099  it = nc + lc + mc
6100  apwas3 = as3**it
6101  pwas3 = apwas3*s32
6102  end if
6103  ex = eppp(it1, it2, it3)
6104  ! y-direction
6105  it3 = nc/2
6106  it2 = (lc-1)/2
6107  it1 = mc/2
6108  ! it=2*(it1+it2+it3)+1
6109  if (s3/=0.) pwas3 = apwas3
6110  ey = epii(it1, it2, it3)
6111  ! z-direction
6112  it3 = nc/2
6113  it2 = (lc-1)/2
6114  it1 = mc/2
6115  ez = eiip(it1, it2, it3)
6116  return
6117  end if
6118  if (itpar==6) then
6119  ! I E I and c<a,b
6120  ! in table 67-d: Ex=E(2t3+1,2t2,2t1)
6121  ! Ey=E(2t3+1,2t2+1,2t1+1)
6122  ! Ez=E(2t3,2t2+1,2t1)
6123  ! values of it1,it2,it3 in table 3-d
6124  ! x-direction
6125  it3 = (nc-1)/2
6126  it2 = (lc+1)/2
6127  it1 = mc/2
6128  if (s3/=0.) then
6129  ! it=2*(it1+it2+it3)+1
6130  it = nc + lc + mc - 1
6131  apwas3 = as3**it
6132  pwas3 = apwas3*s32
6133  end if
6134  ex = eipp(it1, it2, it3)
6135  ! y-direction
6136  it3 = (nc-1)/2
6137  it2 = (lc-1)/2
6138  it1 = mc/2
6139  ! it=2*(it1+it2+it3)+1
6140  if (s3/=0.) pwas3 = apwas3
6141  ey = eiii(it1, it2, it3)
6142  ! z-direction
6143  it3 = (nc+1)/2
6144  it2 = (lc-1)/2
6145  it1 = mc/2
6146  ! it=2*(it1+it2+it3)+1
6147  if (s3/=0.) pwas3 = pwas3*s32
6148  ez = epip(it1, it2, it3)
6149  return
6150  end if
6151  if (itpar==7) then
6152  ! I I E and c<a,b
6153  ! in table 67-f: Ex=E(2t3,2t2,2t1+1)
6154  ! Ey=E(2t3,2t2+1,2t1)
6155  ! Ez=E(2t3+1,2t2+1,2t1+1)
6156  ! values of it1,it2,it3 in table 3-f
6157  ! x-direction
6158  it3 = nc/2
6159  it2 = (lc+1)/2
6160  it1 = (mc-1)/2
6161  if (s3/=0.) then
6162  ! it=2*(it1+it2+it3)+1
6163  it = nc + lc + mc - 1
6164  apwas3 = as3**it
6165  pwas3 = apwas3*s32
6166  end if
6167  ex = eppi(it1, it2, it3)
6168  ! y-direction
6169  it3 = nc/2
6170  it2 = (lc-1)/2
6171  it1 = (mc+1)/2
6172  ! it=2*(it1+it2+it3)+1
6173  ey = epip(it1, it2, it3)
6174  ! z-direction
6175  it3 = nc/2
6176  it2 = (lc-1)/2
6177  it1 = (mc-1)/2
6178  ! it=2*(it1+it2+it3)+1
6179  if (s3/=0.) pwas3 = apwas3
6180  ez = eiii(it1, it2, it3)
6181  return
6182  end if
6183  if (itpar==8) then
6184  ! I I I and c<a,b
6185  ! in table 67-b: Ex=E(2t3+1,2t2,2t1+1)
6186  ! Ey=E(2t3+1,2t2+1,2t1)
6187  ! Ez=E(2t3,2t2+1,2t1+1)
6188  ! values of it1,it2,it3 in table 3-b
6189  ! x-direction
6190  it3 = (nc-1)/2
6191  it2 = (lc+1)/2
6192  it1 = (mc-1)/2
6193  ! it=2*(it1+it2+it3)+1
6194  if (s3/=0.) then
6195  it = nc + lc + mc
6196  pwas3 = as3**it
6197  end if
6198  ex = eipi(it1, it2, it3)
6199  ! y-direction
6200  it3 = (nc-1)/2
6201  it2 = (lc-1)/2
6202  it1 = (mc+1)/2
6203  ! it=2*(it1+it2+it3)+1
6204  ey = eiip(it1, it2, it3)
6205  ! z-direction
6206  it3 = (nc+1)/2
6207  it2 = (lc-1)/2
6208  it1 = (mc-1)/2
6209  ! it=2*(it1+it2+it3)+1
6210  ez = eppi(it1, it2, it3)
6211  return
6212  end if
6213  ! endif of isucc=3----> c<a,b
6214  end if
6215  end subroutine fielde
6216  ! *******************************************************************
6217  ! FUNCTION eppp(it1,it2,it3)
6218  ! E(2it3,2it2,2it1) table 77-a-1
6219  ! *******************************************************************
6220  function eppp(it1, it2, it3)
6221  implicit real *8(a-h, o-z)
6222  common /rms/rms(3, 50), s1, s2, s3
6223  common /partcl/x, y, z
6224  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6225  ! pi2=pi*pi, sqpi=(pi/2)**3/2
6226  common /randu/ck(15), kmax
6227  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6228  ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
6229  ! pwas3=as3**(2(it1+it2+it3)+1)
6230  eppp = 0.
6231  isgnw = 4*(it2+it1) + 5*it3
6232  ipar = isgnw - 2*(isgnw/2)
6233  wsng = -1.
6234  if (ipar==0) wsng = 1.
6235  eppp = wsng*pi2*exs3*rms(3, 3)
6236  eppp = eppp*(tppp(it1,it2,it3)+sppp(it1,it2,it3))
6237  eppp = eppp - 8.*wsng*rms(3, 3)*sqpi*sgppp(it1, it2, it3)
6238  if (s3/=0.) then
6239  sgn1 = -1.
6240  sgn2 = 1.
6241  isgn1 = 3*(it1+it2) + 4*it3
6242  ipar = isgn1 - 2*(isgn1/2)
6243  if (ipar==0) then
6244  sgn1 = 1.
6245  sgn2 = -1
6246  end if
6247  ipt12 = 2*it1 + 1
6248  ipt22 = 2*it2 + 1
6249  ipt212 = 2*(it1+it2)
6250  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6251  e1 = 2.*sgn1*pi2*pwas3*rint*uppp(it1, it2, it3)
6252  scum = 0.
6253  kj = 1
6254  pcas3 = pwas3
6255  do k = 1, kmax, 2
6256  scum = scum + ck(k)*pcas3*vppp(kj)
6257  kj = kj + 1
6258  pcas3 = pcas3*s32
6259  end do
6260  e2 = scum*sgn2*2.*pi2*rint*exs3
6261  eppp = eppp + e1 + e2
6262  end if
6263  return
6264  end function eppp
6265  ! *******************************************************************
6266  ! FUNCTION epip(it1,it2,it3)
6267  ! E(2it3,2it2+1,2it1) table 77-a-2
6268  ! *******************************************************************
6269  function epip(it1, it2, it3)
6270  implicit real *8(a-h, o-z)
6271  common /rms/rms(3, 50), s1, s2, s3
6272  common /partcl/x, y, z
6273  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6274  common /randu/ck(15), kmax
6275  ! pi2=pi*pi, sqpi=(pi/2)**3/2
6276  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6277  ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
6278  ! pwas3=as3**(2(it1+it2+it3)+1)
6279  epip = 0.
6280  isgnw = 4*(it2+it1) + 5*it3 + 2
6281  ipar = isgnw - 2*(isgnw/2)
6282  wsng = -1.
6283  if (ipar==0) wsng = 1.
6284  epip = wsng*pi2*exs3*rms(3, 3)
6285  epip = epip*(tpip(it1,it2,it3)+spip(it1,it2,it3))
6286  epip = epip - 8.*wsng*rms(3, 3)*sqpi*sgpip(it1, it2, it3)
6287  if (s3/=0.) then
6288  pwas31 = pwas3*as3
6289  sgn1 = -1.
6290  sgn2 = 1.
6291  isgn1 = 3*(it1+it2) + 4*it3 + 2
6292  ipar = isgn1 - 2*(isgn1/2)
6293  if (ipar==0) then
6294  sgn1 = 1.
6295  sgn2 = -1.
6296  end if
6297  ipt12 = 2*it1 + 1
6298  ipt22 = 2*it2 + 2
6299  ipt212 = 2*(it1+it2) + 1
6300  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6301  e1 = 2.*sgn1*pi2*pwas31*rint*upip(it1, it2, it3)
6302  scum = 0.
6303  kj = 1
6304  pcas3 = pwas31
6305  do k = 1, kmax, 2
6306  scum = scum + ck(k)*pcas3*vpip(kj)
6307  kj = kj + 1
6308  pcas3 = pcas3*s32
6309  end do
6310  e2 = scum*sgn2*2.*pi2*rint*exs3
6311  epip = epip + (e1+e2)
6312  end if
6313  return
6314  end function epip
6315  ! *******************************************************************
6316  ! FUNCTION eppi(it1,it2,it3)
6317  ! E(2it3,2it2,2it1+1) table 77-a-2
6318  ! *******************************************************************
6319  function eppi(it1, it2, it3)
6320  implicit real *8(a-h, o-z)
6321  common /rms/rms(3, 50), s1, s2, s3
6322  common /partcl/x, y, z
6323  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6324  common /randu/ck(15), kmax
6325  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6326  ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
6327  ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
6328  eppi = 0.
6329  isgnw = 4*(it2+it1) + 5*it3 + 2
6330  ipar = isgnw - 2*(isgnw/2)
6331  wsng = -1.
6332  if (ipar==0) wsng = 1.
6333  eppi = wsng*pi2*exs3*rms(3, 3)
6334  eppi = eppi*(tppi(it1,it2,it3)+sppi(it1,it2,it3))
6335  eppi = eppi - 8.*wsng*rms(3, 3)*sqpi*sgppi(it1, it2, it3)
6336  if (s3/=0.) then
6337  pwas31 = pwas3*as3
6338  sgn1 = -1.
6339  sgn2 = 1.
6340  isgn1 = 3*(it1+it2) + 4*it3 + 2
6341  xsgn1 = isgn1
6342  pari = xsgn1 - 2.*int(xsgn1/2.+0.0001)
6343  if (pari==0.) then
6344  sgn1 = 1.
6345  sgn2 = -1.
6346  end if
6347  ipt12 = 2*it1 + 2
6348  ipt22 = 2*it2 + 1
6349  ipt212 = 2*(it1+it2) + 1
6350  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6351  e1 = 2.*sgn1*pi2*pwas31*rint*uppi(it1, it2, it3)
6352  scum = 0.
6353  kj = 1
6354  pcas3 = pwas31
6355  do k = 1, kmax, 2
6356  scum = scum + ck(k)*pcas3*vppi(kj)
6357  kj = kj + 1
6358  pcas3 = pcas3*s32
6359  end do
6360  e2 = scum*sgn2*2.*pi2*rint*exs3
6361  eppi = eppi + (e1+e2)
6362  end if
6363  return
6364  end function eppi
6365  ! *******************************************************************
6366  ! FUNCTION epii(it1,it2,it3)
6367  ! E(2*it3,2*it2+1,2*it1+1) table 77-a-1
6368  ! *******************************************************************
6369  function epii(it1, it2, it3)
6370  implicit real *8(a-h, o-z)
6371  common /rms/rms(3, 50), s1, s2, s3
6372  common /partcl/x, y, z
6373  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6374  common /randu/ck(15), kmax
6375  ! pi2=pi*pi, sqpi=(pi/2)**3/2
6376  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6377  ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
6378  ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
6379  epii = 0.
6380  isgnw = 4*(it2+it1) + 5*it3 + 4
6381  ipar = isgnw - 2*(isgnw/2)
6382  wsng = -1.
6383  if (ipar==0) wsng = 1.
6384  epii = wsng*pi2*exs3*rms(3, 3)
6385  epii = epii*(tpii(it1,it2,it3)+spii(it1,it2,it3))
6386  epii = epii - 8.*wsng*rms(3, 3)*sqpi*sgpii(it1, it2, it3)
6387  if (s3/=0.) then
6388  pwas31 = pwas3*s32
6389  sgn1 = -1.
6390  sgn2 = 1.
6391  isgn1 = 3*(it1+it2) + 4*it3 + 4
6392  ipar = isgn1 - 2*(isgn1/2)
6393  if (ipar==0) then
6394  sgn1 = 1.
6395  sgn2 = -1
6396  end if
6397  ipt12 = 2*it1 + 2
6398  ipt22 = 2*it2 + 2
6399  ipt212 = 2*(it1+it2+1)
6400  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6401  e1 = 2.*sgn1*pi2*pwas31*rint*upii(it1, it2, it3)
6402  scum = 0.
6403  kj = 1
6404  pcas3 = pwas31
6405  do k = 1, kmax, 2
6406  scum = scum + ck(k)*pcas3*vpii(kj)
6407  kj = kj + 1
6408  pcas3 = pcas3*s32
6409  end do
6410  e2 = scum*sgn2*2.*pi2*rint*exs3
6411  epii = epii + e1 + e2
6412  end if
6413  return
6414  end function epii
6415  ! *******************************************************************
6416  ! FUNCTION eipp(it1,it2,it3)
6417  ! E(2it3+1,2it2,2it1) table 77-b-2
6418  ! *******************************************************************
6419  function eipp(it1, it2, it3)
6420  implicit real *8(a-h, o-z)
6421  common /rms/rms(3, 50), s1, s2, s3
6422  common /partcl/x, y, z
6423  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6424  common /randu/ck(15), kmax
6425  ! pi2=pi*pi, sqpi=(pi/2)**3/2
6426  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6427  ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
6428  ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
6429  eipp = 0.
6430  isgnw = 4*(it2+it1) + 5*it3 + 3
6431  ipar = isgnw - 2*(isgnw/2)
6432  wsng = -1.
6433  if (ipar==0) wsng = 1.
6434  eipp = wsng*sgns3*pi2*exs3*rms(3, 3)
6435  eipp = eipp*(tipp(it1,it2,it3)+sipp(it1,it2,it3))
6436  eipp = eipp + 8.*wsng*rms(3, 3)*sqpi*sgipp(it1, it2, it3)
6437  if (s3/=0.) then
6438  pwas31 = pwas3*as3
6439  sgn1 = -1.
6440  sgn2 = 1.
6441  isgn1 = 3*(it1+it2) + 4*it3 + 3
6442  ipar = isgn1 - 2*(isgn1/2)
6443  if (ipar==0) then
6444  sgn1 = 1.
6445  sgn2 = -1
6446  end if
6447  ipt12 = 2*it1 + 1
6448  ipt22 = 2*it2 + 1
6449  ipt212 = 2*(it1+it2)
6450  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6451  e1 = 2.*sgn1*pi2*pwas31*rint*uipp(it1, it2, it3)*sgns3
6452  scum = 0.
6453  kj = 1
6454  pcas3 = pwas31
6455  do k = 1, kmax, 2
6456  scum = scum + ck(k)*pcas3*vipp(kj)
6457  kj = kj + 1
6458  pcas3 = pcas3*s32
6459  end do
6460  e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6461  eipp = eipp - (e1+e2)
6462  end if
6463  return
6464  end function eipp
6465  ! *******************************************************************
6466  ! FUNCTION eiip(it1,it2,it3)
6467  ! E(2it3+1,2it2+1,2it1) table 77-b-1
6468  ! *******************************************************************
6469  function eiip(it1, it2, it3)
6470  implicit real *8(a-h, o-z)
6471  common /rms/rms(3, 50), s1, s2, s3
6472  common /partcl/x, y, z
6473  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6474  common /randu/ck(15), kmax
6475  ! pi2=pi*pi, sqpi=(pi/2)**3/2
6476  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6477  ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
6478  ! pwas3=as3**(2(it1+it2+it3)+1)
6479  eiip = 0.
6480  isgnw = 4*(it2+it1) + 5*it3 + 5
6481  ipar = isgnw - 2*(isgnw/2)
6482  wsng = -1.
6483  if (ipar==0) wsng = 1.
6484  eiip = wsng*sgns3*pi2*exs3*rms(3, 3)
6485  eiip = eiip*(tiip(it1,it2,it3)+siip(it1,it2,it3))
6486  eiip = eiip + 8.*wsng*rms(3, 3)*sqpi*sgiip(it1, it2, it3)
6487  if (s3/=0.) then
6488  pwas31 = pwas3*s32
6489  sgn1 = -1.
6490  sgn2 = 1.
6491  isgn1 = 3*(it1+it2) + 4*it3 + 5
6492  ipar = isgn1 - 2*(isgn1/2)
6493  if (ipar==0) then
6494  sgn1 = 1.
6495  sgn2 = -1
6496  end if
6497  ipt12 = 2*it1 + 1
6498  ipt22 = 2*it2 + 2
6499  ipt212 = 2*(it1+it2) + 1
6500  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6501  e1 = 2.*sgn1*pi2*pwas31*rint*uiip(it1, it2, it3)*sgns3
6502  scum = 0.
6503  kj = 1
6504  pcas3 = pwas31
6505  do k = 1, kmax, 2
6506  scum = scum + ck(k)*pcas3*viip(kj)
6507  kj = kj + 1
6508  pcas3 = pcas3*s32
6509  end do
6510  e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6511  eiip = eiip - (e1+e2)
6512  end if
6513  return
6514  end function eiip
6515  ! *******************************************************************
6516  ! FUNCTION eipi(it1,it2,it3)
6517  ! E(2*it3+1,2*it2,2*it1+1) table 77-b-1
6518  ! *******************************************************************
6519  function eipi(it1, it2, it3)
6520  implicit real *8(a-h, o-z)
6521  common /rms/rms(3, 50), s1, s2, s3
6522  common /partcl/x, y, z
6523  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6524  common /randu/ck(15), kmax
6525  ! pi2=pi*pi, sqpi=(pi/2)**3/2
6526  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6527  ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
6528  ! pwas3=as3**(2(it1+it2+it3)+1)
6529  eipi = 0.
6530  isgnw = 4*(it2+it1) + 5*it3 + 5
6531  ipar = isgnw - 2*(isgnw/2)
6532  wsng = -1.
6533  if (ipar==0) wsng = 1.
6534  eipi = wsng*sgns3*pi2*exs3*rms(3, 3)
6535  eipi = eipi*(tipi(it1,it2,it3)+sipi(it1,it2,it3))
6536  eipi = eipi + 8.*wsng*rms(3, 3)*sqpi*sgipi(it1, it2, it3)
6537  if (s3/=0.) then
6538  pwas31 = pwas3*s32
6539  sgn1 = -1.
6540  sgn2 = 1.
6541  isgn1 = 3*(it1+it2) + 4*it3 + 5
6542  ipar = isgn1 - 2*(isgn1/2)
6543  if (ipar==0) then
6544  sgn1 = 1.
6545  sgn2 = -1
6546  end if
6547  ipt12 = 2*it1 + 2
6548  ipt22 = 2*it2 + 1
6549  ipt212 = 2*(it1+it2) + 1
6550  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6551  e1 = 2.*sgn1*pi2*pwas31*rint*uipi(it1, it2, it3)*sgns3
6552  scum = 0.
6553  kj = 1
6554  pcas3 = pwas31
6555  do k = 1, kmax, 2
6556  scum = scum + ck(k)*pcas3*vipi(kj)
6557  kj = kj + 1
6558  pcas3 = pcas3*s32
6559  end do
6560  e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6561  eipi = eipi - (e1+e2)
6562  end if
6563  return
6564  end function eipi
6565  ! *******************************************************************
6566  ! FUNCTION eiii(it1,it2,it3)
6567  ! E(2*it3+1,2*it2+1,2*it1+1) table 77-b-2
6568  ! *******************************************************************
6569  function eiii(it1, it2, it3)
6570  implicit real *8(a-h, o-z)
6571  common /rms/rms(3, 50), s1, s2, s3
6572  common /partcl/x, y, z
6573  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6574  common /randu/ck(15), kmax
6575  ! pi2=pi*pi, sqpi=(pi/2)**3/2
6576  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6577  ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
6578  ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
6579  eiii = 0.
6580  isgnw = 4*(it2+it1) + 5*it3 + 5
6581  ipar = isgnw - 2*(isgnw/2)
6582  wsng = -1.
6583  if (ipar==0) wsng = 1.
6584  eiii = wsng*sgns3*pi2*exs3*rms(3, 3)
6585  eiii = eiii*(tiii(it1,it2,it3)+siii(it1,it2,it3))
6586  eiii = eiii + 8.*wsng*rms(3, 3)*sqpi*sgiii(it1, it2, it3)
6587  if (s3/=0.) then
6588  pwas31 = pwas3*s32*as3
6589  sgn1 = -1.
6590  sgn2 = 1.
6591  isgn1 = 3*(it1+it2) + 4*it3 + 5
6592  ipar = isgn1 - 2*(isgn1/2)
6593  if (ipar==0) then
6594  sgn1 = 1.
6595  sgn2 = -1
6596  end if
6597  ipt12 = 2*it1 + 2
6598  ipt22 = 2*it2 + 2
6599  ipt212 = 2*(it1+it2) + 2
6600  rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
6601  e1 = 2.*sgn1*pi2*pwas31*rint*uiii(it1, it2, it3)*sgns3
6602  scum = 0.
6603  kj = 1
6604  pcas3 = pwas31
6605  do k = 1, kmax, 2
6606  scum = scum + ck(k)*pcas3*viii(kj)
6607  kj = kj + 1
6608  pcas3 = pcas3*s32
6609  end do
6610  e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
6611  eiii = eiii - (e1+e2)
6612  end if
6613  return
6614  end function eiii
6615  ! *******************************************************************
6616  ! FUNCTION tipp(it1,it2,it3)
6617  ! Part of W**(2t3+1,2t2,2t1) table 61-b
6618  ! with T(2t3+1,2t2,2t1,j1) table 41
6619  ! *******************************************************************
6620  function tipp(it1, it2, it3)
6621  implicit real *8(a-h, o-z)
6622  common /randu/ck(15), kmax
6623  common /gauss1/absg(40), wg(40), igaus
6624  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6625  common /rms/rms(3, 50), s1, s2, s3
6626  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6627  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6628  common /herfun/hs1(60), hs2(60), hs3(60)
6629  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6630  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6631  common /ftth/makti, maktp
6632  logical makti, maktp
6633 
6634  tipp = 0.
6635  if (.not. makti) then
6636  makti = .true.
6637  kk = 1
6638  do k = 2, kmax, 2
6639  km1 = k - 1
6640  tt1 = 0.
6641  jm1 = 0
6642  xsj1 = 1.
6643  jj1 = 1
6644  do j1 = 1, km1, 2
6645  j1km = km1 - 2*jm1
6646  ! term T(2t3+1,2t2,2t1,j1) in table 41
6647  it3j1 = it3 + jm1
6648  tt = 0.
6649  mm = 1
6650  do m = 1, it3j1 + 1
6651  mm1 = m - 1
6652  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6653  stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
6654  it23jm = 2*(it2+it3+jm1-mm1)
6655  it1m = 2*(it1+mm1)
6656  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
6657  mm = mm + 1
6658  end do
6659  ! s3pw(j1km+1)=as3**j1km
6660  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6661  stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
6662  tt1 = tt1 + tt*stc2i(kk, jj1)
6663  xsj1 = -xsj1
6664  jm1 = jm1 + 1
6665  jj1 = jj1 + 1
6666  end do
6667  tipp = tt1*ck(k) + tipp
6668  kk = kk + 1
6669  end do
6670  return
6671  else
6672  kk = 1
6673  do k = 2, kmax, 2
6674  km1 = k - 1
6675  tt1 = 0.
6676  jm1 = 0
6677  jj1 = 1
6678  do j1 = 1, km1, 2
6679  j1km = km1 - 2*jm1
6680  ! term T(2t3+1,2t2,2t1,j1) in table 41
6681  it3j1 = it3 + jm1
6682  tt = 0.
6683  mm = 1
6684  do m = 1, it3j1 + 1
6685  mm1 = m - 1
6686  it23jm = 2*(it2+it3+jm1-mm1)
6687  it1m = 2*(it1+mm1)
6688  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
6689  mm1 = mm1 + 1
6690  end do
6691  tt1 = tt1 + tt*stc2i(kk, jj1)
6692  jm1 = jm1 + 1
6693  jj1 = jj1 + 1
6694  end do
6695  tipp = tt1*ck(k) + tipp
6696  kk = kk + 1
6697  end do
6698  return
6699  end if
6700  end function tipp
6701  ! *******************************************************************
6702  ! FUNCTION tiip(it1,it2,it3)
6703  ! part of W**(2t3+1,2t2+1,2t1) table 61-b
6704  ! with T(2t3+1,2t2+1,2t1,j1) table 41
6705  ! *******************************************************************
6706  function tiip(it1, it2, it3)
6707  implicit real *8(a-h, o-z)
6708  common /randu/ck(15), kmax
6709  common /gauss1/absg(40), wg(40), igaus
6710  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6711  common /rms/rms(3, 50), s1, s2, s3
6712  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6713  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6714  common /herfun/hs1(60), hs2(60), hs3(60)
6715  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6716  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6717  common /ftth/makti, maktp
6718  logical makti, maktp
6719 
6720  tiip = 0.
6721  if (.not. makti) then
6722  makti = .true.
6723  kk = 1
6724  do k = 2, kmax, 2
6725  km1 = k - 1
6726  tt1 = 0.
6727  jm1 = 0
6728  xsj1 = 1.
6729  jj1 = 1
6730  do j1 = 1, km1, 2
6731  j1km = km1 - 2*jm1
6732  it3j1 = it3 + jm1
6733  tt = 0.
6734  mm = 1
6735  do m = 1, it3j1 + 1
6736  mm1 = m - 1
6737  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6738  stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
6739  it23jm = 2*(it2+it3+jm1-mm1)
6740  it1m = 2*(it1+mm1)
6741  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
6742  mm = mm + 1
6743  end do
6744  ! s3pw(j1km+1)=as3**j1km
6745  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6746  stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
6747  tt1 = tt1 + tt*stc2i(kk, jj1)
6748  xsj1 = -xsj1
6749  jm1 = jm1 + 1
6750  jj1 = jj1 + 1
6751  end do
6752  tiip = tt1*ck(k) + tiip
6753  kk = kk + 1
6754  end do
6755  return
6756  else
6757  kk = 1
6758  do k = 2, kmax, 2
6759  km1 = k - 1
6760  tt1 = 0.
6761  jm1 = 0
6762  jj1 = 1
6763  do j1 = 1, km1, 2
6764  j1km = km1 - 2*jm1
6765  ! term T(2t3+1,2t2,2t1,j1) in table 41
6766  it3j1 = it3 + jm1
6767  tt = 0.
6768  mm = 1
6769  do m = 1, it3j1 + 1
6770  mm1 = m - 1
6771  it23jm = 2*(it2+it3+jm1-mm1)
6772  it1m = 2*(it1+mm1)
6773  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
6774  mm = mm + 1
6775  end do
6776  tt1 = tt1 + tt*stc2i(kk, jj1)
6777  jm1 = jm1 + 1
6778  jj1 = jj1 + 1
6779  end do
6780  tiip = tt1*ck(k) + tiip
6781  kk = kk + 1
6782  end do
6783  return
6784  end if
6785  end function tiip
6786  ! *******************************************************************
6787  ! FUNCTION tipi(it1,it2,it3)
6788  ! part of W**(2t3+1,2t2,2t1+1) in table 61-b
6789  ! with T(2t3+1,2t2,2t1+1,j1) in table 41
6790  ! *******************************************************************
6791  function tipi(it1, it2, it3)
6792  implicit real *8(a-h, o-z)
6793  common /randu/ck(15), kmax
6794  common /gauss1/absg(40), wg(40), igaus
6795  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6796  common /rms/rms(3, 50), s1, s2, s3
6797  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6798  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6799  common /herfun/hs1(60), hs2(60), hs3(60)
6800  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6801  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6802  common /ftth/makti, maktp
6803  logical makti, maktp
6804 
6805  tipi = 0.
6806  if (.not. makti) then
6807  makti = .true.
6808  kk = 1
6809  do k = 2, kmax, 2
6810  km1 = k - 1
6811  tt1 = 0.
6812  jm1 = 0
6813  xsj1 = 1.
6814  jj1 = 1
6815  do j1 = 1, km1, 2
6816  j1km = km1 - 2*jm1
6817  ! term T(2t3+1,2t2+1,2t1,j1) in table 41
6818  it3j1 = it3 + jm1
6819  tt = 0.
6820  mm = 1
6821  do m = 1, it3j1 + 1
6822  mm1 = m - 1
6823  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6824  stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
6825  it23jm = 2*(it2+it3+jm1-mm1)
6826  it1m = 2*(it1+mm1)
6827  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
6828  mm = mm + 1
6829  end do
6830  ! s3pw(j1km+1)=as3**j1km
6831  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6832  stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
6833  tt1 = tt1 + tt*stc2i(kk, jj1)
6834  xsj1 = -xsj1
6835  jm1 = jm1 + 1
6836  jj1 = jj1 + 1
6837  end do
6838  tipi = tt1*ck(k) + tipi
6839  kk = kk + 1
6840  end do
6841  return
6842  else
6843  kk = 1
6844  do k = 2, kmax, 2
6845  km1 = k - 1
6846  tt1 = 0.
6847  jm1 = 0
6848  jj1 = 1
6849  do j1 = 1, km1, 2
6850  j1km = km1 - 2*jm1
6851  ! term T(2t3+1,2t2,2t1,j1) in table 41
6852  it3j1 = it3 + jm1
6853  tt = 0.
6854  mm = 1
6855  do m = 1, it3j1 + 1
6856  mm1 = m - 1
6857  it23jm = 2*(it2+it3+jm1-mm1)
6858  it1m = 2*(it1+mm1)
6859  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
6860  mm = mm + 1
6861  end do
6862  tt1 = tt1 + tt*stc2i(kk, jj1)
6863  jm1 = jm1 + 1
6864  jj1 = jj1 + 1
6865  end do
6866  tipi = tt1*ck(k) + tipi
6867  kk = kk + 1
6868  end do
6869  return
6870  end if
6871  end function tipi
6872  ! *******************************************************************
6873  ! FUNCTION tiii(it1,it2,it3)
6874  ! part of W**(2t3+1,2t2+1,2t1+1) in table 61-b
6875  ! with T(2t3+1,2t2+1,2t1+1,j1) in table 41
6876  ! *******************************************************************
6877  function tiii(it1, it2, it3)
6878  implicit real *8(a-h, o-z)
6879  common /randu/ck(15), kmax
6880  common /gauss1/absg(40), wg(40), igaus
6881  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6882  common /rms/rms(3, 50), s1, s2, s3
6883  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6884  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6885  common /herfun/hs1(60), hs2(60), hs3(60)
6886  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6887  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6888  common /ftth/makti, maktp
6889  logical makti, maktp
6890 
6891  tiii = 0.
6892  if (.not. makti) then
6893  makti = .true.
6894  kk = 1
6895  do k = 2, kmax, 2
6896  km1 = k - 1
6897  tt1 = 0.
6898  jm1 = 0
6899  xsj1 = 1.
6900  jj1 = 1
6901  do j1 = 1, km1, 2
6902  j1km = km1 - 2*jm1
6903  ! term T(2t3+1,2t2+1,2t1,j1) in table 41
6904  it3j1 = it3 + jm1
6905  tt = 0.
6906  mm = 1
6907  do m = 1, it3j1 + 1
6908  mm1 = m - 1
6909  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6910  stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
6911  it23jm = 2*(it2+it3+jm1-mm1)
6912  it1m = 2*(it1+mm1)
6913  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
6914  mm = mm + 1
6915  end do
6916  ! s3pw(j1km+1)=as3**j1km
6917  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
6918  stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
6919  tt1 = tt1 + tt*stc2i(kk, jj1)
6920  xsj1 = -xsj1
6921  jm1 = jm1 + 1
6922  jj1 = jj1 + 1
6923  end do
6924  tiii = tt1*ck(k) + tiii
6925  kk = kk + 1
6926  end do
6927  return
6928  else
6929  kk = 1
6930  do k = 2, kmax, 2
6931  km1 = k - 1
6932  tt1 = 0.
6933  jm1 = 0
6934  jj1 = 1
6935  do j1 = 1, km1, 2
6936  j1km = km1 - 2*jm1
6937  ! term T(2t3+1,2t2+1,2t1+1,j1) in table 41
6938  it3j1 = it3 + jm1
6939  tt = 0.
6940  mm = 1
6941  do m = 1, it3j1 + 1
6942  mm1 = m - 1
6943  it23jm = 2*(it2+it3+jm1-mm1)
6944  it1m = 2*(it1+mm1)
6945  tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
6946  mm1 = mm1 + 1
6947  end do
6948  tt1 = tt1 + tt*stc2i(kk, jj1)
6949  jm1 = jm1 + 1
6950  jj1 = jj1 + 1
6951  end do
6952  tiii = tt1*ck(k) + tiii
6953  kk = kk + 1
6954  end do
6955  return
6956  end if
6957  end function tiii
6958  ! *******************************************************************
6959  ! FUNCTION tppp(it1,it2,it3)
6960  ! part of W**(2t3,2t2,2t1) in table 61-a
6961  ! with T(2t3,2t2,2t1,j1) in table 41
6962  ! *******************************************************************
6963  function tppp(it1, it2, it3)
6964  implicit real *8(a-h, o-z)
6965  common /randu/ck(15), kmax
6966  common /gauss1/absg(40), wg(40), igaus
6967  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
6968  common /rms/rms(3, 50), s1, s2, s3
6969  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
6970  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
6971  common /herfun/hs1(60), hs2(60), hs3(60)
6972  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
6973  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
6974  common /ftth/makti, maktp
6975  logical makti, maktp
6976 
6977  tppp = 0.
6978  if (.not. maktp) then
6979  maktp = .true.
6980  kk = 1
6981  do k = 2, kmax, 2
6982  km1 = k - 1
6983  xsj1 = 1
6984  tt1 = 0.
6985  jm1 = 0
6986  jj1 = 1
6987  do j1 = 1, km1, 2
6988  j1km = km1 - 2*jm1 - 1
6989  ! j1km must be always greather or equal to zero
6990  if (j1km<0) go to 100
6991  ! T(2t3,2t2,2t1,j1) in table 41
6992  it3j1 = it3 + jm1
6993  tt = 0.
6994  mm = 1
6995  do m = 1, it3j1 + 1
6996  mm1 = m - 1
6997  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
6998  stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
6999  it23jm = 2*(it2+it3+jm1-mm1)
7000  it1m = 2*(it1+mm1)
7001  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
7002  mm = mm + 1
7003  end do
7004  ! s3pw(j1km+1)=as3**j1km
7005  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7006  stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
7007  tt1 = tt1 + tt*stc2p(kk, jj1)
7008  xsj1 = -xsj1
7009  jm1 = jm1 + 1
7010  jj1 = jj1 + 1
7011  end do
7012  tppp = tt1*ck(k) + tppp
7013  kk = kk + 1
7014 100 continue
7015  end do
7016  return
7017  else
7018  kk = 1
7019  do k = 2, kmax, 2
7020  km1 = k - 1
7021  tt1 = 0.
7022  jm1 = 0
7023  jj1 = 1
7024  do j1 = 1, km1, 2
7025  j1km = km1 - 2*jm1 - 1
7026  ! j1km must be always greather or equal to zero
7027  if (j1km<0) go to 200
7028  ! T(2t3,2t2,2t1,j1) in table 41
7029  it3j1 = it3 + jm1
7030  tt = 0.
7031  mm = 1
7032  do m = 1, it3j1 + 1
7033  mm1 = m - 1
7034  it23jm = 2*(it2+it3+jm1-mm1)
7035  it1m = 2*(it1+mm1)
7036  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
7037  mm = mm + 1
7038  end do
7039  tt1 = tt1 + tt*stc2p(kk, jj1)
7040  jm1 = jm1 + 1
7041  jj1 = jj1 + 1
7042  end do
7043  tppp = tt1*ck(k) + tppp
7044  kk = kk + 1
7045 200 continue
7046  end do
7047  return
7048  end if
7049  end function tppp
7050  ! *******************************************************************
7051  ! FUNCTION tpip(it1,it2,it3)
7052  ! the part of W**(2t3,2t2,2t1+1) in table 61-a
7053  ! with T(2t3,2t2,2t1+1,j1) in table 41
7054  ! *******************************************************************
7055  function tpip(it1, it2, it3)
7056  implicit real *8(a-h, o-z)
7057  common /randu/ck(15), kmax
7058  common /gauss1/absg(40), wg(40), igaus
7059  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7060  common /rms/rms(3, 50), s1, s2, s3
7061  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7062  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7063  common /herfun/hs1(60), hs2(60), hs3(60)
7064  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7065  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
7066  common /ftth/makti, maktp
7067  logical makti, maktp
7068 
7069  tpip = 0.
7070  if (.not. maktp) then
7071  maktp = .true.
7072  kk = 1
7073  do k = 2, kmax, 2
7074  km1 = k - 1
7075  xsj1 = 1
7076  tt1 = 0.
7077  jm1 = 0
7078  jj1 = 1
7079  do j1 = 1, km1, 2
7080  j1km = km1 - 2*jm1 - 1
7081  ! j1km must be always greather or equal to zero
7082  if (j1km<0) go to 100
7083  ! T(2t3,2t2,2t1,j1) in table 41
7084  it3j1 = it3 + jm1
7085  tt = 0.
7086  mm = 1
7087  do m = 1, it3j1 + 1
7088  mm1 = m - 1
7089  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
7090  stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
7091  it23jm = 2*(it2+it3+jm1-mm1)
7092  it1m = 2*(it1+mm1)
7093  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
7094  mm = mm + 1
7095  end do
7096  ! s3pw(j1km+1)=as3**j1km
7097  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7098  stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
7099  tt1 = tt1 + tt*stc2p(kk, jj1)
7100  xsj1 = -xsj1
7101  jm1 = jm1 + 1
7102  jj1 = jj1 + 1
7103  end do
7104  tpip = tt1*ck(k) + tpip
7105  kk = kk + 1
7106 100 continue
7107  end do
7108  return
7109  else
7110  kk = 1
7111  do k = 2, kmax, 2
7112  km1 = k - 1
7113  tt1 = 0.
7114  jm1 = 0
7115  jj1 = 1
7116  do j1 = 1, km1, 2
7117  j1km = km1 - 2*jm1 - 1
7118  ! j1km must be always greather or equal to zero
7119  if (j1km<0) go to 200
7120  ! T(2t3,2t2,2t1,j1) in table 41
7121  it3j1 = it3 + jm1
7122  tt = 0.
7123  mm = 1
7124  do m = 1, it3j1 + 1
7125  mm1 = m - 1
7126  it23jm = 2*(it2+it3+jm1-mm1)
7127  it1m = 2*(it1+mm1)
7128  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
7129  mm = mm + 1
7130  end do
7131  tt1 = tt1 + tt*stc2p(kk, jj1)
7132  jm1 = jm1 + 1
7133  jj1 = jj1 + 1
7134  end do
7135  tpip = tt1*ck(k) + tpip
7136  kk = kk + 1
7137 200 continue
7138  end do
7139  return
7140  end if
7141  end function tpip
7142  ! *******************************************************************
7143  ! FUNCTION tppi(it1,it2,it3)
7144  ! part of W**(2t3,2t2,2t1+1) in table 61-a
7145  ! with T(2t3,2t2,2t1+1,j1) in table 41
7146  ! *******************************************************************
7147  function tppi(it1, it2, it3)
7148  implicit real *8(a-h, o-z)
7149  common /randu/ck(15), kmax
7150  common /gauss1/absg(40), wg(40), igaus
7151  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7152  common /rms/rms(3, 50), s1, s2, s3
7153  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7154  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7155  common /herfun/hs1(60), hs2(60), hs3(60)
7156  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7157  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
7158  common /ftth/makti, maktp
7159  logical makti, maktp
7160 
7161  tppi = 0.
7162  if (.not. maktp) then
7163  maktp = .true.
7164  kk = 1
7165  do k = 2, kmax, 2
7166  km1 = k - 1
7167  xsj1 = 1
7168  tt1 = 0.
7169  jm1 = 0
7170  jj1 = 1
7171  do j1 = 1, km1, 2
7172  j1km = km1 - 2*jm1 - 1
7173  ! j1km must be always greather or equal to zero
7174  if (j1km<0) go to 100
7175  ! T(2t3,2t2,2t1,j1) in table 41
7176  it3j1 = it3 + jm1
7177  tt = 0.
7178  mm = 1
7179  do m = 1, it3j1 + 1
7180  mm1 = m - 1
7181  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
7182  stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
7183  it23jm = 2*(it2+it3+jm1-mm1)
7184  it1m = 2*(it1+mm1)
7185  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
7186  mm = mm + 1
7187  end do
7188  ! s3pw(j1km+1)=as3**j1km
7189  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7190  stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
7191  tt1 = tt1 + tt*stc2p(kk, jj1)
7192  xsj1 = -xsj1
7193  jm1 = jm1 + 1
7194  jj1 = jj1 + 1
7195  end do
7196  tppi = tt1*ck(k) + tppi
7197  kk = kk + 1
7198 100 continue
7199  end do
7200  return
7201  else
7202  kk = 1
7203  do k = 2, kmax, 2
7204  km1 = k - 1
7205  tt1 = 0.
7206  jm1 = 0
7207  jj1 = 1
7208  do j1 = 1, km1, 2
7209  j1km = km1 - 2*jm1 - 1
7210  ! j1km must be always greather or equal to zero
7211  if (j1km<0) go to 200
7212  ! T(2t3,2t2,2t1,j1) in table 41
7213  it3j1 = it3 + jm1
7214  tt = 0.
7215  mm = 1
7216  do m = 1, it3j1 + 1
7217  mm1 = m - 1
7218  it23jm = 2*(it2+it3+jm1-mm1)
7219  it1m = 2*(it1+mm1)
7220  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
7221  mm = mm + 1
7222  end do
7223  tt1 = tt1 + tt*stc2p(kk, jj1)
7224  jm1 = jm1 + 1
7225  jj1 = jj1 + 1
7226  end do
7227  tppi = tt1*ck(k) + tppi
7228  kk = kk + 1
7229 200 continue
7230  end do
7231  return
7232  end if
7233  end function tppi
7234  ! *******************************************************************
7235  ! FUNCTION tpii(it1,it2,it3)
7236  ! part of W**(2t3,2t2+1,2t1+1) in table 61-a
7237  ! with T(2t3,2t2+1,2t1+1,j1) in table 41
7238  ! *******************************************************************
7239  function tpii(it1, it2, it3)
7240  implicit real *8(a-h, o-z)
7241  common /randu/ck(15), kmax
7242  common /gauss1/absg(40), wg(40), igaus
7243  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7244  common /rms/rms(3, 50), s1, s2, s3
7245  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7246  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7247  common /herfun/hs1(60), hs2(60), hs3(60)
7248  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7249  common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
7250  common /ftth/makti, maktp
7251  logical makti, maktp
7252 
7253  tpii = 0.
7254  if (.not. maktp) then
7255  maktp = .true.
7256  kk = 1
7257  do k = 2, kmax, 2
7258  km1 = k - 1
7259  xsj1 = 1
7260  tt1 = 0.
7261  jm1 = 0
7262  jj1 = 1
7263  do j1 = 1, km1, 2
7264  j1km = km1 - 2*jm1 - 1
7265  ! j1km must be always greather or equal to zero
7266  if (j1km<0) go to 100
7267  ! T(2t3,2t2,2t1,j1) in table 41
7268  it3j1 = it3 + jm1
7269  tt = 0.
7270  mm = 1
7271  do m = 1, it3j1 + 1
7272  mm1 = m - 1
7273  stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
7274  stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
7275  it23jm = 2*(it2+it3+jm1-mm1)
7276  it1m = 2*(it1+mm1)
7277  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
7278  mm = mm + 1
7279  end do
7280  ! s3pw(j1km+1)=as3**j1km
7281  stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
7282  stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
7283  tt1 = tt1 + tt*stc2p(kk, jj1)
7284  xsj1 = -xsj1
7285  jm1 = jm1 + 1
7286  jj1 = jj1 + 1
7287  end do
7288  tpii = tt1*ck(k) + tpii
7289  kk = kk + 1
7290 100 continue
7291  end do
7292  return
7293  else
7294  kk = 1
7295  do k = 2, kmax, 2
7296  km1 = k - 1
7297  tt1 = 0.
7298  jm1 = 0
7299  jj1 = 1
7300  do j1 = 1, km1, 2
7301  j1km = km1 - 2*jm1 - 1
7302  ! j1km must be always greather or equal to zero
7303  if (j1km<0) go to 200
7304  ! T(2t3,2t2,2t1,j1) in table 41
7305  it3j1 = it3 + jm1
7306  tt = 0.
7307  mm = 1
7308  do m = 1, it3j1 + 1
7309  mm1 = m - 1
7310  it23jm = 2*(it2+it3+jm1-mm1)
7311  it1m = 2*(it1+mm1)
7312  tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
7313  mm = mm + 1
7314  end do
7315  tt1 = tt1 + tt*stc2p(kk, jj1)
7316  jm1 = jm1 + 1
7317  jj1 = jj1 + 1
7318  end do
7319  tpii = tt1*ck(k) + tpii
7320  kk = kk + 1
7321 200 continue
7322  end do
7323  return
7324  end if
7325  end function tpii
7326  ! *******************************************************************
7327  ! FUNCTION sipp(it1,it2,it3)
7328  ! second part of W**(2t3+1,2t2,2t1) in table 61-b
7329  ! with S(2t3+1,2t2,2t1,j1) in table 70-b
7330  ! *******************************************************************
7331  function sipp(it1, it2, it3)
7332  implicit real *8(a-h, o-z)
7333  common /consta/vl, pi, xmat, rpel, qst
7334  common /randu/ck(15), kmax
7335  common /gauss1/absg(40), wg(40), igaus
7336  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7337  common /rms/rms(3, 50), s1, s2, s3
7338  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7339  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7340  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7341  common /hass/carg(100), sarg(100), argip(100)
7342  common /fssk/sstci(8, 8), sstcp(8, 8)
7343  common /fsth/maksi, maksp
7344  logical maksi, maksp
7345 
7346  sipp = 0.
7347  it1p = 2*it1 + 1
7348  it2p = 2*it2 + 1
7349  it12p = 2*(it1+it2+1) + 1
7350  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7351  kk = 1
7352  do k = 1, kmax, 2
7353  xsj1 = -1.
7354  km1 = k - 1
7355  tt1 = 0.
7356  jm1 = 0
7357  jj2 = 1
7358  do j1 = 1, km1, 2
7359  jj1 = 2*jm1 + 1
7360  j1km = km1 - jj1
7361  if (j1km<0) go to 100
7362  ! S(2t3+1,2t2,2t1,j1) computation
7363  ! Gauss quadrature in table 70-b
7364  i1123j1 = it1 + it2 + it3 + jm1 + 1
7365  i2123j1 = 2*i1123j1
7366  tt = 0.
7367  do ig = 1, igaus
7368  ! Hermite functions are in the table hsint(ig,,ind )
7369  ! caution!!! in the table hsint the indice ind is starting from 1
7370  ! i2123j1 is starting from zero
7371  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7372  htm0 = hsint(ig, 2, i2123j1+1)
7373  htp0 = hsint(ig, 1, i2123j1+1)
7374  tt = tt + base/sqblam(ig)*(htm0+htp0)
7375  end do
7376  if (.not. maksi) then
7377  ! s3pw(j1km+1)=as3**j1km
7378  stock = 2.*xsj1*s3pw(j1km+1)
7379  sstci(kk, jj2) = fpar(km1, jj1)*stock
7380  xsj1 = -xsj1
7381  end if
7382  tt1 = sstci(kk, jj2)*tt + tt1
7383  jj2 = jj2 + 1
7384  jm1 = jm1 + 1
7385  end do
7386  sipp = sipp + tt1*ck(k)
7387  kk = kk + 1
7388  ! enddo from k (k=1,kmax+1)
7389 100 continue
7390  end do
7391  sipp = sipp*bsp
7392  maksi = .true.
7393  return
7394  end function sipp
7395  ! *******************************************************************
7396  ! FUNCTION siip(it1,it2,it3)
7397  ! W**(2t3+1,2t2+1,2t1) in table 61-b
7398  ! with S(2t3+1,2t2+1,2t1,j1) in table 70-b
7399  ! *******************************************************************
7400  function siip(it1, it2, it3)
7401  implicit real *8(a-h, o-z)
7402  common /consta/vl, pi, xmat, rpel, qst
7403  common /randu/ck(15), kmax
7404  common /gauss1/absg(40), wg(40), igaus
7405  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7406  common /rms/rms(3, 50), s1, s2, s3
7407  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7408  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7409  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7410  common /fssk/sstci(8, 8), sstcp(8, 8)
7411  common /fsth/maksi, maksp
7412  logical maksi, maksp
7413 
7414  siip = 0.
7415  it1p = 2*it1 + 1
7416  it2p = 2*it2 + 2
7417  it12p = 2*(it1+it2+2)
7418  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7419  kk = 1
7420  do k = 1, kmax, 2
7421  xsj1 = -1.
7422  km1 = k - 1
7423  tt1 = 0.
7424  jm1 = 0
7425  jj2 = 1
7426  do j1 = 1, km1, 2
7427  jj1 = 2*jm1 + 1
7428  j1km = km1 - jj1
7429  if (j1km<0) go to 100
7430  ! S(2t3+1,2t2,2t1,j1) computation
7431  ! Gauss quadrature in table 70-b
7432  i1123j1 = it1 + it2 + it3 + jm1 + 2
7433  i2123j1 = 2*i1123j1 - 1
7434  tt = 0.
7435  do ig = 1, igaus
7436  ! Hermite functions
7437  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7438  htm0 = hsint(ig, 2, i2123j1+1)
7439  htp0 = hsint(ig, 1, i2123j1+1)
7440  tt = tt + base*(htp0-htm0)
7441  end do
7442  if (.not. maksi) then
7443  ! s3pw(j1km+1)=as3**j1km
7444  stock = 2.*xsj1*s3pw(j1km+1)
7445  sstci(kk, jj2) = fpar(km1, jj1)*stock
7446  xsj1 = -xsj1
7447  end if
7448  tt1 = sstci(kk, jj2)*tt + tt1
7449  jj2 = jj2 + 1
7450  jm1 = jm1 + 1
7451  end do
7452  siip = siip + tt1*ck(k)
7453  kk = kk + 1
7454  ! enddo from k (k=1,kmax+1)
7455 100 continue
7456  end do
7457  siip = siip*bsp
7458  maksi = .true.
7459  return
7460  end function siip
7461  ! *******************************************************************
7462  ! FUNCTION sipi(it1,it2,it3)
7463  ! part of W**(2t3+1,2t2,2t1+1) in table 61-b
7464  ! with S(2t3+1,2t2,2t1+1,j1) given in table 70-b
7465  ! *******************************************************************
7466  function sipi(it1, it2, it3)
7467  implicit real *8(a-h, o-z)
7468  common /consta/vl, pi, xmat, rpel, qst
7469  common /randu/ck(15), kmax
7470  common /gauss1/absg(40), wg(40), igaus
7471  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7472  common /rms/rms(3, 50), s1, s2, s3
7473  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7474  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7475  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7476  common /fssk/sstci(8, 8), sstcp(8, 8)
7477  common /fsth/maksi, maksp
7478  logical maksi, maksp
7479 
7480  sipi = 0.
7481  it1p = 2*it1 + 2
7482  it2p = 2*it2 + 1
7483  it12p = 2*(it1+it2+2)
7484  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7485  kk = 1
7486  do k = 1, kmax, 2
7487  xsj1 = -1.
7488  km1 = k - 1
7489  tt1 = 0.
7490  jm1 = 0
7491  jj2 = 1
7492  do j1 = 1, km1, 2
7493  jj1 = 2*jm1 + 1
7494  j1km = km1 - jj1
7495  if (j1km<0) go to 100
7496  ! S(2t3+1,2t2,2t1,j1) computation
7497  ! Gauss quadrature in table 70-b
7498  i1123j1 = it1 + it2 + it3 + jm1 + 2
7499  i2123j1 = 2*i1123j1 - 1
7500  tt = 0.
7501  do ig = 1, igaus
7502  ! Hermite functions
7503  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7504  htm0 = hsint(ig, 2, i2123j1+1)
7505  htp0 = hsint(ig, 1, i2123j1+1)
7506  tt = tt + base*(htp0+htm0)
7507  end do
7508  if (.not. maksi) then
7509  ! s3pw(j1km+1)=as3**j1km
7510  stock = 2.*xsj1*s3pw(j1km+1)
7511  sstci(kk, jj2) = fpar(km1, jj1)*stock
7512  xsj1 = -xsj1
7513  end if
7514  tt1 = sstci(kk, jj2)*tt + tt1
7515  jj2 = jj2 + 1
7516  jm1 = jm1 + 1
7517  end do
7518  sipi = sipi + tt1*ck(k)
7519  kk = kk + 1
7520  ! enddo from k (k=1,kmax+1)
7521 100 continue
7522  end do
7523  sipi = sipi*bsp
7524  maksi = .true.
7525  return
7526  end function sipi
7527  ! *******************************************************************
7528  ! FUNCTION siii(it1,it2,it3)
7529  ! part of W**(2t3+1,2t2+1,2t1+1) in table 61-b
7530  ! with S(2t3+1,2t2+1,2t1+1,j1) in table 70-b
7531  ! *******************************************************************
7532  function siii(it1, it2, it3)
7533  implicit real *8(a-h, o-z)
7534  common /consta/vl, pi, xmat, rpel, qst
7535  common /randu/ck(15), kmax
7536  common /gauss1/absg(40), wg(40), igaus
7537  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7538  common /rms/rms(3, 50), s1, s2, s3
7539  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7540  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7541  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7542  common /fssk/sstci(8, 8), sstcp(8, 8)
7543  common /fsth/maksi, maksp
7544  logical maksi, maksp
7545 
7546  siii = 0.
7547  it1p = 2*it1 + 2
7548  it2p = 2*it2 + 2
7549  it12p = 2*(it1+it2+2) + 1
7550  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7551  kk = 1
7552  do k = 1, kmax, 2
7553  xsj1 = -1.
7554  km1 = k - 1
7555  tt1 = 0.
7556  jm1 = 0
7557  jj2 = 1
7558  do j1 = 1, km1, 2
7559  jj1 = 2*jm1 + 1
7560  j1km = km1 - jj1
7561  if (j1km<0) go to 100
7562  ! S(2t3+1,2t2,2t1,j1) computation
7563  ! Gauss quadrature in table 70-b
7564  i1123j1 = it1 + it2 + it3 + jm1 + 2
7565  i2123j1 = 2*i1123j1
7566  tt = 0.
7567  do ig = 1, igaus
7568  ! Hermite functions
7569  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7570  htm0 = hsint(ig, 2, i2123j1+1)
7571  htp0 = hsint(ig, 1, i2123j1+1)
7572  tt = tt + base*(htm0-htp0)/sqblam(ig)
7573  end do
7574  if (.not. maksi) then
7575  ! s3pw(j1km+1)=as3**j1km
7576  stock = 2.*xsj1*s3pw(j1km+1)
7577  sstci(kk, jj2) = fpar(km1, jj1)*stock
7578  xsj1 = -xsj1
7579  end if
7580  tt1 = sstci(kk, jj2)*tt + tt1
7581  jj2 = jj2 + 1
7582  jm1 = jm1 + 1
7583  end do
7584  siii = siii + tt1*ck(k)
7585  ! enddo from k (k=1,kmax+1)
7586  kk = kk + 1
7587 100 continue
7588  end do
7589  siii = -siii*bsp
7590  maksi = .true.
7591  return
7592  end function siii
7593  ! *******************************************************************
7594  ! FUNCTION sppp(it1,it2,it3)
7595  ! part of W**(2t3,2t2,2t1) in table 61-a
7596  ! with S(2t3,2t2,2t1,j1) given in table 70-a
7597  ! *******************************************************************
7598  function sppp(it1, it2, it3)
7599  implicit real *8(a-h, o-z)
7600  common /consta/vl, pi, xmat, rpel, qst
7601  common /randu/ck(15), kmax
7602  common /gauss1/absg(40), wg(40), igaus
7603  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7604  common /rms/rms(3, 50), s1, s2, s3
7605  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7606  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7607  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7608  common /fssk/sstci(8, 8), sstcp(8, 8)
7609  common /fsth/maksi, maksp
7610  logical maksi, maksp
7611 
7612  sppp = 0.
7613  it1p = 2*it1 + 1
7614  it2p = 2*it2 + 1
7615  it12p = 2*(it1+it2+1) + 1
7616  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7617  kk = 1
7618  do k = 1, kmax, 2
7619  km1 = k - 1
7620  xsj1 = 1
7621  tt1 = 0.
7622  jj1 = 1
7623  do j1 = 1, k
7624  jm1 = j1 - 1
7625  j1km = km1 - 2*jm1
7626  if (j1km<0) go to 100
7627  ! j1km must be always greather or equal to zero
7628  ! Gauss quadrature in table 70-a
7629  i1123j1 = it1 + it2 + it3 + jm1
7630  i2123j1 = 2*i1123j1
7631  tt = 0.
7632  do ig = 1, igaus
7633  ! Hermite functions
7634  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
7635  htm0 = hsint(ig, 2, i2123j1+1)
7636  htp0 = hsint(ig, 1, i2123j1+1)
7637  tt = tt + base*(htm0+htp0)/sqblam(ig)
7638  end do
7639  if (.not. maksp) then
7640  ! s3pw(j1km+1)=as3**j1km
7641  stock = 2.*xsj1*s3pw(j1km+1)
7642  sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
7643  xsj1 = -xsj1
7644  end if
7645  tt1 = sstcp(kk, jj1)*tt + tt1
7646  ! enddo from j1
7647  jj1 = jj1 + 1
7648  end do
7649 100 continue
7650  sppp = sppp + tt1*ck(k)
7651  ! enddo from k (k=1,kmax+1)
7652  kk = kk + 1
7653  end do
7654  sppp = sppp*bsp
7655  maksp = .true.
7656  return
7657  end function sppp
7658  ! *******************************************************************
7659  ! FUNCTION spip(it1,it2,it3)
7660  ! part of W**(2t3,2t2,2t1+1) in table 61-a
7661  ! with S(2t3,2t2,2t1+1,j1) given in table 70-a
7662  ! *******************************************************************
7663  function spip(it1, it2, it3)
7664  implicit real *8(a-h, o-z)
7665  common /consta/vl, pi, xmat, rpel, qst
7666  common /randu/ck(15), kmax
7667  common /gauss1/absg(40), wg(40), igaus
7668  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7669  common /rms/rms(3, 50), s1, s2, s3
7670  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7671  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7672  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7673  common /fssk/sstci(8, 8), sstcp(8, 8)
7674  common /fsth/maksi, maksp
7675  logical maksi, maksp
7676 
7677  spip = 0.
7678  it1p = 2*it1 + 1
7679  it2p = 2*it2 + 2
7680  it12p = 2*(it1+it2+1) + 2
7681  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7682  kk = 1
7683  do k = 1, kmax, 2
7684  km1 = k - 1
7685  xsj1 = 1
7686  tt1 = 0.
7687  jj1 = 1
7688  do j1 = 1, k
7689  jm1 = j1 - 1
7690  j1km = km1 - 2*jm1
7691  if (j1km<0) go to 100
7692  ! j1km must be always greather or equal to zero
7693  ! Gauss quadrature in table 70-a
7694  i1123j1 = it1 + it2 + it3 + jm1
7695  i2123j1 = 2*i1123j1 + 1
7696  tt = 0.
7697  do ig = 1, igaus
7698  ! Hermite functions
7699  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
7700  htm0 = hsint(ig, 2, i2123j1+1)
7701  htp0 = hsint(ig, 1, i2123j1+1)
7702  tt = tt + base*(htp0-htm0)
7703  end do
7704  if (.not. maksp) then
7705  ! s3pw(j1km+1)=as3**j1km
7706  stock = 2.*xsj1*s3pw(j1km+1)
7707  sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
7708  xsj1 = -xsj1
7709  end if
7710  tt1 = sstcp(kk, jj1)*tt + tt1
7711  ! enddo from j1
7712  jj1 = jj1 + 1
7713  end do
7714 100 continue
7715  spip = spip + tt1*ck(k)
7716  kk = kk + 1
7717  ! enddo from k (k=1,kmax+1)
7718  end do
7719  spip = spip*bsp
7720  maksp = .true.
7721  return
7722  end function spip
7723  ! *******************************************************************
7724  ! FUNCTION sppi(it1,it2,it3)
7725  ! part of W**(2t3,2t2,2t1+1) in table 61-a
7726  ! with S(2t3,2t2,2t1+1,j1) given in table 70-a
7727  ! *******************************************************************
7728  function sppi(it1, it2, it3)
7729  implicit real *8(a-h, o-z)
7730  common /consta/vl, pi, xmat, rpel, qst
7731  common /randu/ck(15), kmax
7732  common /gauss1/absg(40), wg(40), igaus
7733  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7734  common /rms/rms(3, 50), s1, s2, s3
7735  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7736  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7737  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7738  common /fssk/sstci(8, 8), sstcp(8, 8)
7739  common /fsth/maksi, maksp
7740  logical maksi, maksp
7741 
7742  sppi = 0.
7743  it1p = 2*it1 + 2
7744  it2p = 2*it2 + 1
7745  it12p = 2*(it1+it2+1) + 2
7746  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7747  kk = 1
7748  do k = 1, kmax, 2
7749  km1 = k - 1
7750  xsj1 = 1.
7751  tt1 = 0.
7752  jj1 = 1
7753  do j1 = 1, k
7754  jm1 = j1 - 1
7755  j1km = km1 - 2*jm1
7756  ! j1km must be always greather or equal to zero
7757  if (j1km<0) go to 100
7758  ! Gauss quadrature in table 70-a
7759  i1123j1 = it1 + it2 + it3 + jm1
7760  i2123j1 = 2*i1123j1 + 1
7761  tt = 0.
7762  do ig = 1, igaus
7763  ! Hermite functions
7764  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
7765  htm0 = hsint(ig, 2, i2123j1+1)
7766  htp0 = hsint(ig, 1, i2123j1+1)
7767  tt = tt + base*(htm0+htp0)
7768  end do
7769  if (.not. maksp) then
7770  ! s3pw(j1km+1)=as3**j1km
7771  stock = 2.*xsj1*s3pw(j1km+1)
7772  sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
7773  xsj1 = -xsj1
7774  end if
7775  tt1 = sstcp(kk, jj1)*tt + tt1
7776  ! enddo from j1
7777  jj1 = jj1 + 1
7778  end do
7779 100 continue
7780  sppi = sppi + tt1*ck(k)
7781  ! enddo from k (k=1,kmax+1)
7782  kk = kk + 1
7783  end do
7784  sppi = sppi*bsp
7785  maksp = .true.
7786  return
7787  end function sppi
7788  ! *******************************************************************
7789  ! FUNCTION spii(it1,it2,it3)
7790  ! part of W**(2t3,2t2,2t1+1) in table 61-a
7791  ! with S(2t3,2t2+1,2t1+1,j1) given in table 70-a
7792  ! *******************************************************************
7793  function spii(it1, it2, it3)
7794  implicit real *8(a-h, o-z)
7795  common /consta/vl, pi, xmat, rpel, qst
7796  common /randu/ck(15), kmax
7797  common /gauss1/absg(40), wg(40), igaus
7798  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
7799  common /rms/rms(3, 50), s1, s2, s3
7800  common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
7801  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
7802  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7803  common /fssk/sstci(8, 8), sstcp(8, 8)
7804  common /fsth/maksi, maksp
7805  logical maksi, maksp
7806 
7807  spii = 0.
7808  it1p = 2*it1 + 2
7809  it2p = 2*it2 + 2
7810  it12p = 2*(it1+it2+2) + 1
7811  bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
7812  kk = 1
7813  do k = 1, kmax, 2
7814  km1 = k - 1
7815  xsj1 = 1.
7816  tt1 = 0.
7817  jj1 = 1
7818  do j1 = 1, k
7819  jm1 = j1 - 1
7820  j1km = km1 - 2*jm1
7821  if (j1km<0) go to 100
7822  ! j1km must be always greather or equal to zero
7823  ! Gauss quadrature in table 70-a
7824  i1123j1 = it1 + it2 + it3 + jm1
7825  i2123j1 = 2*i1123j1 + 2
7826  tt = 0.
7827  do ig = 1, igaus
7828  ! Hermite functions
7829  base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
7830  htm0 = hsint(ig, 2, i2123j1+1)
7831  htp0 = hsint(ig, 1, i2123j1+1)
7832  tt = tt + base*(htm0-htp0)/sqblam(ig)
7833  end do
7834  if (.not. maksp) then
7835  ! s3pw(j1km+1)=as3**j1km
7836  stock = 2.*xsj1*s3pw(j1km+1)
7837  sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
7838  xsj1 = -xsj1
7839  end if
7840  tt1 = sstcp(kk, jj1)*tt + tt1
7841  ! enddo from j1
7842  jj1 = jj1 + 1
7843  end do
7844 100 continue
7845  spii = spii + tt1*ck(k)
7846  kk = kk + 1
7847  ! enddo from k (k=1,kmax+1)
7848  end do
7849  maksp = .true.
7850  spii = -spii*bsp
7851  return
7852  end function spii
7853  ! ****************************************************************
7854  ! funtions sigma in table 14
7855  ! these functions are used in tables 77-a-1 to 77-b-2
7856  ! sgppp -->l,m and n even
7857  ! sgpip --> l even, m odd, n even
7858  ! .................................
7859  ! *****************************************************************
7860  ! *******************************************************************
7861  ! FUNCTION sgppp(it1,it2,it3)
7862  ! FUNCTION sigma(2t3,2t2,2t1) in table 14
7863  ! in E(2t3,2t2,2t1) in table 77-a-1
7864  ! *******************************************************************
7865  function sgppp(it1, it2, it3)
7866  implicit real *8(a-h, o-z)
7867  common /rms/rms(3, 50), s1, s2, s3
7868  common /herfun/hs1(60), hs2(60), hs3(60)
7869  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7870  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
7871  common /sgpth/mksgi, mksgp
7872  logical mksgi, mksgp
7873 
7874  sgppp = 0.
7875  if (it3==0) return
7876  sgn = -1.
7877  if (.not. mksgp) then
7878  mksgp = .true.
7879  do ik = 1, it3
7880  sg1 = 0.
7881  km2 = 2*ik - 2
7882  it3kp1 = it3 - ik + 1
7883  it3k = 2*(it3-ik)
7884  sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
7885  do jk = 1, it3kp1
7886  jkm1 = jk - 1
7887  jt3kj = 2*(it3-ik-jkm1)
7888  jt23kj = 2*(it3+it2-ik-jkm1)
7889  jt1j = 2*(it1+jkm1)
7890  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
7891  sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
7892  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
7893  end do
7894  sgppp = sgppp + sgp3(ik)*sg1
7895  sgn = -sgn
7896  end do
7897  return
7898  else
7899  do ik = 1, it3
7900  sg1 = 0.
7901  it3kp1 = it3 - ik + 1
7902  do jk = 1, it3kp1
7903  jkm1 = jk - 1
7904  jt23kj = 2*(it3+it2-ik-jkm1)
7905  jt1j = 2*(it1+jkm1)
7906  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
7907  end do
7908  sgppp = sgppp + sgp3(ik)*sg1
7909  end do
7910  return
7911  end if
7912  end function sgppp
7913  ! *******************************************************************
7914  ! FUNCTION sgpip(it1,it2,it3)
7915  ! FUNCTION sigma(2t3,2t+1,2t1) in table 14
7916  ! is in E(2t3,2t2+1,2t1) given in table 77-a-2
7917  ! *******************************************************************
7918  function sgpip(it1, it2, it3)
7919  implicit real *8(a-h, o-z)
7920  common /rms/rms(3, 50), s1, s2, s3
7921  common /herfun/hs1(60), hs2(60), hs3(60)
7922  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7923  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
7924  common /sgpth/mksgi, mksgp
7925  logical mksgi, mksgp
7926 
7927  sgpip = 0.
7928  if (it3==0) return
7929  sgn = -1.
7930  if (.not. mksgp) then
7931  mksgp = .true.
7932  do ik = 1, it3
7933  sg1 = 0.
7934  km2 = 2*ik - 2
7935  it3kp1 = it3 - ik + 1
7936  it3k = 2*(it3-ik)
7937  ! omment hs30=hs3(km2+1)*rms(3,it3k+1)
7938  sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
7939  do jk = 1, it3kp1
7940  jkm1 = jk - 1
7941  jt3kj = 2*(it3-ik-jkm1)
7942  jt23kj = 2*(it3+it2-ik-jkm1)
7943  jt1j = 2*(it1+jkm1)
7944  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
7945  sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
7946  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
7947  end do
7948  sgpip = sgpip + sgp3(ik)*sg1
7949  sgn = -sgn
7950  end do
7951  return
7952  else
7953  do ik = 1, it3
7954  sg1 = 0.
7955  it3kp1 = it3 - ik + 1
7956  do jk = 1, it3kp1
7957  jkm1 = jk - 1
7958  jt23kj = 2*(it3+it2-ik-jkm1)
7959  jt1j = 2*(it1+jkm1)
7960  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
7961  end do
7962  sgpip = sgpip + sgp3(ik)*sg1
7963  end do
7964  return
7965  end if
7966  end function sgpip
7967  ! *******************************************************************
7968  ! FUNCTION sgppi(it1,it2,it3)
7969  ! FUNCTION sigma(2t3,2t2,2t1+1) in table 14
7970  ! is in E(2t3,2t2,2t1+1) in table 77-a-2
7971  ! *******************************************************************
7972  function sgppi(it1, it2, it3)
7973  implicit real *8(a-h, o-z)
7974  common /rms/rms(3, 50), s1, s2, s3
7975  common /herfun/hs1(60), hs2(60), hs3(60)
7976  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
7977  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
7978  common /sgpth/mksgi, mksgp
7979  logical mksgi, mksgp
7980 
7981  sgppi = 0.
7982  if (it3==0) return
7983  sgn = -1.
7984  if (.not. mksgp) then
7985  mksgp = .true.
7986  do ik = 1, it3
7987  sg1 = 0.
7988  km2 = 2*ik - 2
7989  it3kp1 = it3 - ik + 1
7990  it3k = 2*(it3-ik)
7991  sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
7992  do jk = 1, it3kp1
7993  jkm1 = jk - 1
7994  jt3kj = 2*(it3-ik-jkm1)
7995  jt23kj = 2*(it3+it2-ik-jkm1)
7996  jt1j = 2*(it1+jkm1)
7997  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
7998  sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
7999  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8000  end do
8001  sgppi = sgppi + sgp3(ik)*sg1
8002  sgn = -sgn
8003  end do
8004  return
8005  else
8006  do ik = 1, it3
8007  sg1 = 0.
8008  it3kp1 = it3 - ik + 1
8009  do jk = 1, it3kp1
8010  jkm1 = jk - 1
8011  jt23kj = 2*(it3+it2-ik-jkm1)
8012  jt1j = 2*(it1+jkm1)
8013  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8014  end do
8015  sgppi = sgppi + sgp3(ik)*sg1
8016  end do
8017  return
8018  end if
8019  end function sgppi
8020  ! *******************************************************************
8021  ! FUNCTION sgpii(it1,it2,it3)
8022  ! FUNCTION sigma(2t3,2t2+1,2t1+1) in table 14
8023  ! correspond to E(2t3,2t2+1,2t1+1) in table 77-a-1
8024  ! *******************************************************************
8025  function sgpii(it1, it2, it3)
8026  implicit real *8(a-h, o-z)
8027  common /rms/rms(3, 50), s1, s2, s3
8028  common /herfun/hs1(60), hs2(60), hs3(60)
8029  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8030  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8031  common /sgpth/mksgi, mksgp
8032  logical mksgi, mksgp
8033 
8034  sgpii = 0.
8035  if (it3==0) return
8036  sgn = -1.
8037  if (.not. mksgp) then
8038  mksgp = .true.
8039  do ik = 1, it3
8040  sg1 = 0.
8041  km2 = 2*ik - 2
8042  it3kp1 = it3 - ik + 1
8043  it3k = 2*(it3-ik)
8044  sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
8045  do jk = 1, it3kp1
8046  jkm1 = jk - 1
8047  jt3kj = 2*(it3-ik-jkm1)
8048  jt23kj = 2*(it3+it2-ik-jkm1)
8049  jt1j = 2*(it1+jkm1)
8050  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8051  sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
8052  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8053  end do
8054  sgpii = sgpii + sgp3(ik)*sg1
8055  sgn = -sgn
8056  end do
8057  return
8058  else
8059  do ik = 1, it3
8060  sg1 = 0.
8061  it3kp1 = it3 - ik + 1
8062  do jk = 1, it3kp1
8063  jkm1 = jk - 1
8064  jt23kj = 2*(it3+it2-ik-jkm1)
8065  jt1j = 2*(it1+jkm1)
8066  sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8067  end do
8068  sgpii = sgpii + sgp3(ik)*sg1
8069  end do
8070  return
8071  end if
8072  end function sgpii
8073  ! *******************************************************************
8074  ! FUNCTION sgipp(it1,it2,it3)
8075  ! FUNCTION sigma(2t3+1,2t2,2t1) in table 14
8076  ! E(2t3+1,2t2,2t1) is given in table 77-b-2
8077  ! *******************************************************************
8078  function sgipp(it1, it2, it3)
8079  implicit real *8(a-h, o-z)
8080  common /rms/rms(3, 50), s1, s2, s3
8081  common /herfun/hs1(60), hs2(60), hs3(60)
8082  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8083  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8084  common /sgpth/mksgi, mksgp
8085  logical mksgi, mksgp
8086 
8087  sgipp = 0.
8088  if (it3<=0) return
8089  sgn = -1.
8090  if (.not. mksgi) then
8091  mksgi = .true.
8092  do ik = 1, it3
8093  sg1 = 0.
8094  km1 = 2*ik - 1
8095  it3kp1 = it3 - ik + 1
8096  it3k = 2*(it3-ik)
8097  sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8098  do jk = 1, it3kp1
8099  jkm1 = jk - 1
8100  jt3kj = 2*(it3-ik-jkm1)
8101  jt23kj = 2*(it3+it2-ik-jkm1)
8102  jt1j = 2*(it1+jkm1)
8103  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8104  sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
8105  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
8106  end do
8107  sgipp = sgipp + sgi3(ik)*sg1
8108  sgn = -sgn
8109  end do
8110  return
8111  else
8112  do ik = 1, it3
8113  sg1 = 0.
8114  it3kp1 = it3 - ik + 1
8115  do jk = 1, it3kp1
8116  jkm1 = jk - 1
8117  jt23kj = 2*(it3+it2-ik-jkm1)
8118  jt1j = 2*(it1+jkm1)
8119  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
8120  end do
8121  sgipp = sgipp + sgi3(ik)*sg1
8122  end do
8123  return
8124  end if
8125  end function sgipp
8126  ! *******************************************************************
8127  ! FUNCTION sgiip(it1,it2,it3)
8128  ! FUNCTION sigma(2t3+1,2t2+1,2t1) in table 14
8129  ! inside E(2t3+1,2t2+1,2t1) given in table 77-b-1
8130  ! *******************************************************************
8131  function sgiip(it1, it2, it3)
8132  implicit real *8(a-h, o-z)
8133  common /rms/rms(3, 50), s1, s2, s3
8134  common /herfun/hs1(60), hs2(60), hs3(60)
8135  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8136  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8137  common /sgpth/mksgi, mksgp
8138  logical mksgi, mksgp
8139 
8140  sgiip = 0.
8141  if (it3==0) return
8142  sgn = -1.
8143  if (.not. mksgi) then
8144  mksgi = .true.
8145  do ik = 1, it3
8146  sg1 = 0.
8147  km1 = 2*ik - 1
8148  it3kp1 = it3 - ik + 1
8149  it3k = 2*(it3-ik)
8150  sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8151  do jk = 1, it3kp1
8152  jkm1 = jk - 1
8153  jt3kj = 2*(it3-ik-jkm1)
8154  jt23kj = 2*(it3+it2-ik-jkm1)
8155  jt1j = 2*(it1+jkm1)
8156  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8157  sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
8158  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
8159  end do
8160  sgiip = sgiip + sgi3(ik)*sg1
8161  sgn = -sgn
8162  end do
8163  return
8164  else
8165  do ik = 1, it3
8166  sg1 = 0.
8167  it3kp1 = it3 - ik + 1
8168  do jk = 1, it3kp1
8169  jkm1 = jk - 1
8170  jt23kj = 2*(it3+it2-ik-jkm1)
8171  jt1j = 2*(it1+jkm1)
8172  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
8173  end do
8174  sgiip = sgiip + sgi3(ik)*sg1
8175  end do
8176  return
8177  end if
8178  end function sgiip
8179  ! *******************************************************************
8180  ! FUNCTION sgipi(it1,it2,it3)
8181  ! FUNCTION sigma(2t3+1,2t2,2t1+1) in table 14
8182  ! in E(2t3+1,2t2,2t1+1) in table 77-b-1
8183  ! *******************************************************************
8184  function sgipi(it1, it2, it3)
8185  implicit real *8(a-h, o-z)
8186  common /rms/rms(3, 50), s1, s2, s3
8187  common /herfun/hs1(60), hs2(60), hs3(60)
8188  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8189  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8190  common /sgpth/mksgi, mksgp
8191  logical mksgi, mksgp
8192 
8193  sgipi = 0.
8194  if (it3==0) return
8195  sgn = -1.
8196  if (.not. mksgi) then
8197  mksgi = .true.
8198  do ik = 1, it3
8199  sg1 = 0.
8200  km1 = 2*ik - 1
8201  it3kp1 = it3 - ik + 1
8202  it3k = 2*(it3-ik)
8203  sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8204  do jk = 1, it3kp1
8205  jkm1 = jk - 1
8206  jt3kj = 2*(it3-ik-jkm1)
8207  jt23kj = 2*(it3+it2-ik-jkm1)
8208  jt1j = 2*(it1+jkm1)
8209  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8210  sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
8211  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8212  end do
8213  sgipi = sgipi + sgi3(ik)*sg1
8214  sgn = -sgn
8215  end do
8216  return
8217  else
8218  do ik = 1, it3
8219  sg1 = 0.
8220  it3kp1 = it3 - ik + 1
8221  do jk = 1, it3kp1
8222  jkm1 = jk - 1
8223  jt23kj = 2*(it3+it2-ik-jkm1)
8224  jt1j = 2*(it1+jkm1)
8225  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
8226  end do
8227  sgipi = sgipi + sgi3(ik)*sg1
8228  end do
8229  return
8230  end if
8231  end function sgipi
8232  ! *******************************************************************
8233  ! FUNCTION sgiii(it1,it2,it3)
8234  ! FUNCTION sigma(2t3+1,2t2+1,2t1+1) in table 14
8235  ! in E(2t3+1,2t2+1,2t1+1) in table 77-b-2
8236  ! *******************************************************************
8237  function sgiii(it1, it2, it3)
8238  implicit real *8(a-h, o-z)
8239  common /rms/rms(3, 50), s1, s2, s3
8240  common /herfun/hs1(60), hs2(60), hs3(60)
8241  common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
8242  common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
8243  common /sgpth/mksgi, mksgp
8244  logical mksgi, mksgp
8245 
8246  sgiii = 0.
8247  if (it3==0) return
8248  sgn = -1.
8249  if (.not. mksgi) then
8250  mksgi = .true.
8251  do ik = 1, it3
8252  sg1 = 0.
8253  km1 = 2*ik - 1
8254  it3kp1 = it3 - ik + 1
8255  it3k = 2*(it3-ik)
8256  sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
8257  do jk = 1, it3kp1
8258  jkm1 = jk - 1
8259  jt3kj = 2*(it3-ik-jkm1)
8260  jt23kj = 2*(it3+it2-ik-jkm1)
8261  jt1j = 2*(it1+jkm1)
8262  stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
8263  sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
8264  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8265  end do
8266  sgiii = sgiii + sgi3(ik)*sg1
8267  sgn = -sgn
8268  end do
8269  return
8270  else
8271  do ik = 1, it3
8272  sg1 = 0.
8273  it3kp1 = it3 - ik + 1
8274  do jk = 1, it3kp1
8275  jkm1 = jk - 1
8276  jt23kj = 2*(it3+it2-ik-jkm1)
8277  jt1j = 2*(it1+jkm1)
8278  sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
8279  end do
8280  sgiii = sgiii + sgi3(ik)*sg1
8281  end do
8282  return
8283  end if
8284  end function sgiii
8285  ! *****************************************************************************
8286  ! Functions U and V given in tables 75 and 76
8287  ! uppp ---> l,m,n even
8288  ! upip ---> l even, m odd, n even
8289  ! .................................
8290  ! *****************************************************************************
8291  ! *******************************************************************
8292  ! FUNCTION uppp(it1,it2,it3)
8293  ! the integral U(2t3,2t2,2t1,thet) is given in table 75
8294  ! the summation with cos(thet)**2*t1,cos(thet)**2*t2 is found in
8295  ! table 77-a-1
8296  ! *******************************************************************
8297  function uppp(it1, it2, it3)
8298  implicit real *8(a-h, o-z)
8299  common /rms/rms(3, 50), s1, s2, s3
8300  common /gauss1/absg(40), wg(40), igaus
8301  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8302  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8303  common /expmod/ragp(40, 100), ragm1(40, 40)
8304  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8305 
8306  uppp = 0.
8307  ind = 2*(it1+it2+it3) + 1
8308  idt1 = 2*it1 + 1
8309  idt2 = 2*it2 + 1
8310  do j = 1, igaus
8311  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8312  u = 0.
8313  do i = 1, igaus
8314  arcc(i, j) = ragp(i, ind)*akpcc(i, j)
8315  u = u + arcc(i, j)*epsi1(i, j)
8316  end do
8317  uppp = uppp + cs(j)*u
8318  end do
8319  return
8320  end function uppp
8321  ! *******************************************************************
8322  ! FUNCTION upip(it1,it2,it3)
8323  ! the integral U(2t3,2t2+1,2t1,thet) is given in table 75
8324  ! the summation with cos(thet)**2t1,cos(thet)**(2t2+1) is in
8325  ! table 77-a-2
8326  ! *******************************************************************
8327  function upip(it1, it2, it3)
8328  implicit real *8(a-h, o-z)
8329  common /rms/rms(3, 50), s1, s2, s3
8330  common /gauss1/absg(40), wg(40), igaus
8331  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8332  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8333  common /expmod/ragp(40, 100), ragm1(40, 40)
8334  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8335 
8336  upip = 0.
8337  ind = 2*(it1+it2+it3) + 2
8338  idt1 = 2*it1 + 1
8339  idt2 = 2*it2 + 2
8340  do j = 1, igaus
8341  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8342  u = 0.
8343  do i = 1, igaus
8344  arcs(i, j) = ragp(i, ind)*akpcs(i, j)
8345  u = u + arcs(i, j)*epsi1(i, j)
8346  end do
8347  upip = upip + cs(j)*u
8348  end do
8349  return
8350  end function upip
8351  ! *******************************************************************
8352  ! FUNCTION uppi(it1,it2,it3)
8353  ! the integral U(2t3,2t2,2t1+1,thet) in table 75
8354  ! the summation with cos(thet)**(2*t1+1),cos(thet)**2*t2 in
8355  ! table 77-a-2
8356  ! *******************************************************************
8357  function uppi(it1, it2, it3)
8358  implicit real *8(a-h, o-z)
8359  common /rms/rms(3, 50), s1, s2, s3
8360  common /gauss1/absg(40), wg(40), igaus
8361  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8362  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8363  common /expmod/ragp(40, 100), ragm1(40, 40)
8364  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8365 
8366  uppi = 0.
8367  ind = 2*(it1+it2+it3) + 2
8368  idt1 = 2*it1 + 2
8369  idt2 = 2*it2 + 1
8370  do j = 1, igaus
8371  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8372  u = 0.
8373  do i = 1, igaus
8374  arsc(i, j) = ragp(i, ind)*akpsc(i, j)
8375  u = u + arsc(i, j)*epsi1(i, j)
8376  end do
8377  uppi = uppi + cs(j)*u
8378  end do
8379  return
8380  end function uppi
8381  ! *******************************************************************
8382  ! FUNCTION upii(it1,it2,it3)
8383  ! the integral U(2*t3,2*t2+1,2*t1+1,thet) table 75
8384  ! the summation with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1)
8385  ! table 77-a-1
8386  ! *******************************************************************
8387  function upii(it1, it2, it3)
8388  implicit real *8(a-h, o-z)
8389  common /rms/rms(3, 50), s1, s2, s3
8390  common /gauss1/absg(40), wg(40), igaus
8391  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8392  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8393  common /expmod/ragp(40, 100), ragm1(40, 40)
8394  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8395 
8396  upii = 0.
8397  ind = 2*(it1+it2+it3+1) + 1
8398  idt1 = 2*it1 + 2
8399  idt2 = 2*it2 + 2
8400  do j = 1, igaus
8401  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8402  u = 0.
8403  do i = 1, igaus
8404  arss(i, j) = ragp(i, ind)*akpss(i, j)
8405  u = u + arss(i, j)*epsi1(i, j)
8406  end do
8407  upii = upii + cs(j)*u
8408  end do
8409  return
8410  end function upii
8411  ! *******************************************************************
8412  ! FUNCTION uipp(it1,it2,it3)
8413  ! the integral U(2*t3+1,2*t2,2*t1,thet) table 75
8414  ! for the summation with cos(thet)**2*t1,cos(thet)**2*t2 see
8415  ! table 77-b-2
8416  ! *******************************************************************
8417  function uipp(it1, it2, it3)
8418  implicit real *8(a-h, o-z)
8419  common /rms/rms(3, 50), s1, s2, s3
8420  common /gauss1/absg(40), wg(40), igaus
8421  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8422  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8423  common /expmod/ragp(40, 100), ragm1(40, 40)
8424  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8425 
8426  uipp = 0.
8427  ind = 2*(it1+it2+it3+1)
8428  idt1 = 2*it1 + 1
8429  idt2 = 2*it2 + 1
8430  do j = 1, igaus
8431  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8432  u = 0.
8433  do i = 1, igaus
8434  arcc(i, j) = ragp(i, ind)*akpcc(i, j)
8435  u = u + arcc(i, j)*epsi1(i, j)
8436  end do
8437  uipp = uipp + cs(j)*u
8438  end do
8439  return
8440  end function uipp
8441  ! *******************************************************************
8442  ! FUNCTION uiip(it1,it2,it3)
8443  ! the integral U(2*t3+1,2*t2+1,2*t1,thet) table 75
8444  ! summation over cos(thet)**2*t1,cos(thet)**(2*t2+1) table 77-b-1
8445  ! *******************************************************************
8446  function uiip(it1, it2, it3)
8447  implicit real *8(a-h, o-z)
8448  common /rms/rms(3, 50), s1, s2, s3
8449  common /gauss1/absg(40), wg(40), igaus
8450  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8451  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8452  common /expmod/ragp(40, 100), ragm1(40, 40)
8453  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8454 
8455  uiip = 0.
8456  ind = 2*(it1+it2+it3+1) + 1
8457  idt1 = 2*it1 + 1
8458  idt2 = 2*it2 + 2
8459  do j = 1, igaus
8460  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8461  u = 0.
8462  do i = 1, igaus
8463  arcs(i, j) = ragp(i, ind)*akpcs(i, j)
8464  u = u + arcs(i, j)*epsi1(i, j)
8465  end do
8466  uiip = uiip + cs(j)*u
8467  end do
8468  return
8469  end function uiip
8470  ! *******************************************************************
8471  ! FUNCTION uipi(it1,it2,it3)
8472  ! the integral U(2t3+1,2t2,2t1+1,thet) table 75
8473  ! summation over cos(thet)**(2*t1+1),cos(thet)**2*t2 table 77-b-1
8474  ! *******************************************************************
8475  function uipi(it1, it2, it3)
8476  implicit real *8(a-h, o-z)
8477  common /rms/rms(3, 50), s1, s2, s3
8478  common /gauss1/absg(40), wg(40), igaus
8479  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8480  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8481  common /expmod/ragp(40, 100), ragm1(40, 40)
8482  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8483 
8484  uipi = 0.
8485  ind = 2*(it1+it2+it3+1) + 1
8486  idt1 = 2*it1 + 2
8487  idt2 = 2*it2 + 1
8488  do j = 1, igaus
8489  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8490  u = 0.
8491  do i = 1, igaus
8492  arsc(i, j) = ragp(i, ind)*akpsc(i, j)
8493  u = u + arsc(i, j)*epsi1(i, j)
8494  end do
8495  uipi = uipi + cs(j)*u
8496  end do
8497  return
8498  end function uipi
8499  ! *******************************************************************
8500  ! FUNCTION uiii(it1,it2,it3)
8501  ! the integral U(2*t3+1,2*t2+1,2*t1+1,thet) table 75
8502  ! summation with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1)
8503  ! (see table 77-b-2)
8504  ! *******************************************************************
8505  function uiii(it1, it2, it3)
8506  implicit real *8(a-h, o-z)
8507  common /rms/rms(3, 50), s1, s2, s3
8508  common /gauss1/absg(40), wg(40), igaus
8509  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8510  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8511  common /expmod/ragp(40, 100), ragm1(40, 40)
8512  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8513 
8514  uiii = 0.
8515  ind = 2*(it1+it2+it3+1) + 2
8516  idt1 = 2*it1 + 2
8517  idt2 = 2*it2 + 2
8518  do j = 1, igaus
8519  cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
8520  u = 0.
8521  do i = 1, igaus
8522  arss(i, j) = ragp(i, ind)*akpss(i, j)
8523  u = u + arss(i, j)*epsi1(i, j)
8524  end do
8525  uiii = uiii + cs(j)*u
8526  end do
8527  return
8528  end function uiii
8529  ! *******************************************************************
8530  ! FUNCTION vppp(k)
8531  ! the integral V(2t3,2t2,2t1,k,thet) table 76
8532  ! sum with cos(thet)**2*t1,cos(thet)**2*t2 (see table 77-a-1)
8533  ! *******************************************************************
8534  function vppp(k)
8535  implicit real *8(a-h, o-z)
8536  common /rms/rms(3, 50), s1, s2, s3
8537  common /gauss1/absg(40), wg(40), igaus
8538  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8539  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8540  common /expmod/ragp(40, 100), ragm1(40, 40)
8541  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8542 
8543  vppp = 0.
8544  do j = 1, igaus
8545  u = 0.
8546  do i = 1, igaus
8547  u = u + arcc(i, j)*ragm1(i, k)*epsi2(i, j)
8548  end do
8549  vppp = vppp + cs(j)*u
8550  end do
8551  return
8552  end function vppp
8553  ! *******************************************************************
8554  ! FUNCTION vpip(k)
8555  ! the integral V(2t3,2t2+1,2t1,k,thet) table 76
8556  ! sum with cos(thet)**2*t1,cos(thet)**(2*t2+1) (table 77-a-2)
8557  ! *******************************************************************
8558  function vpip(k)
8559  implicit real *8(a-h, o-z)
8560  common /rms/rms(3, 50), s1, s2, s3
8561  common /gauss1/absg(40), wg(40), igaus
8562  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8563  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8564  common /expmod/ragp(40, 100), ragm1(40, 40)
8565  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8566 
8567  vpip = 0.
8568  do j = 1, igaus
8569  u = 0.
8570  do i = 1, igaus
8571  u = u + arcs(i, j)*ragm1(i, k)*epsi2(i, j)
8572  end do
8573  vpip = vpip + cs(j)*u
8574  end do
8575  return
8576  end function vpip
8577  ! *******************************************************************
8578  ! FUNCTION vppi(k)
8579  ! the integral V(2t3,2t2,2t1+1,k,thet) table 76
8580  ! sum wih cos(thet)**2*t1,cos(thet)**(2*t2+1) (table 77-a-2)
8581  ! *******************************************************************
8582  function vppi(k)
8583  implicit real *8(a-h, o-z)
8584  common /rms/rms(3, 50), s1, s2, s3
8585  common /gauss1/absg(40), wg(40), igaus
8586  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8587  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8588  common /expmod/ragp(40, 100), ragm1(40, 40)
8589  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8590 
8591  vppi = 0.
8592  do j = 1, igaus
8593  u = 0.
8594  do i = 1, igaus
8595  u = u + arsc(i, j)*ragm1(i, k)*epsi2(i, j)
8596  end do
8597  vppi = vppi + cs(j)*u
8598  end do
8599  return
8600  end function vppi
8601  ! *******************************************************************
8602  ! FUNCTION vpii(k)
8603  ! the integral V(2*t3,2*t2+1,2*t1+1,k,thet) table 76
8604  ! sum with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1) (table 77-a-1)
8605  ! *******************************************************************
8606  function vpii(k)
8607  implicit real *8(a-h, o-z)
8608  common /rms/rms(3, 50), s1, s2, s3
8609  common /gauss1/absg(40), wg(40), igaus
8610  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8611  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8612  common /expmod/ragp(40, 100), ragm1(40, 40)
8613  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8614 
8615  vpii = 0.
8616  do j = 1, igaus
8617  u = 0.
8618  do i = 1, igaus
8619  u = u + arss(i, j)*ragm1(i, k)*epsi2(i, j)
8620  end do
8621  vpii = vpii + cs(j)*u
8622  end do
8623  return
8624  end function vpii
8625  ! *******************************************************************
8626  ! FUNCTION vipp(k)
8627  ! the integral V(2*t3+1,2*t2,2*t1,thet) table 76
8628  ! sum with cos(thet)**2*t1,cos(thet)**2*t2 ( table 77-b-2)
8629  ! *******************************************************************
8630  function vipp(k)
8631  implicit real *8(a-h, o-z)
8632  common /rms/rms(3, 50), s1, s2, s3
8633  common /gauss1/absg(40), wg(40), igaus
8634  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8635  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8636  common /expmod/ragp(40, 100), ragm1(40, 40)
8637  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8638 
8639  vipp = 0.
8640  do j = 1, igaus
8641  u = 0.
8642  do i = 1, igaus
8643  u = u + arcc(i, j)*ragm1(i, k)*epsi2(i, j)
8644  end do
8645  vipp = vipp + cs(j)*u
8646  end do
8647  return
8648  end function vipp
8649  ! *******************************************************************
8650  ! FUNCTION viip(k)
8651  ! the integral V(2*t3+1,2*t2+1,2*t1,thet) table 76
8652  ! sum with cos(thet)**2*t1,cos(thet)**(2*t2+1) (table 77-b-1)
8653  ! *******************************************************************
8654  function viip(k)
8655  implicit real *8(a-h, o-z)
8656  common /rms/rms(3, 50), s1, s2, s3
8657  common /gauss1/absg(40), wg(40), igaus
8658  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8659  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8660  common /expmod/ragp(40, 100), ragm1(40, 40)
8661  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8662 
8663  viip = 0.
8664  do j = 1, igaus
8665  u = 0.
8666  do i = 1, igaus
8667  u = u + arcs(i, j)*ragm1(i, k)*epsi2(i, j)
8668  end do
8669  viip = viip + cs(j)*u
8670  end do
8671  return
8672  end function viip
8673  ! *******************************************************************
8674  ! FUNCTION vipi(k)
8675  ! the integral V(2*t3+1,2*t2,2*t1+1,k,thet) table 76
8676  ! sum with cos(thet)**(2*t1+1),cos(thet)**2*t2 (table 77-b-1)
8677  ! *******************************************************************
8678  function vipi(k)
8679  implicit real *8(a-h, o-z)
8680  common /rms/rms(3, 50), s1, s2, s3
8681  common /gauss1/absg(40), wg(40), igaus
8682  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8683  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8684  common /expmod/ragp(40, 100), ragm1(40, 40)
8685  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8686 
8687  vipi = 0.
8688  do j = 1, igaus
8689  u = 0.
8690  do i = 1, igaus
8691  u = u + arsc(i, j)*ragm1(i, k)*epsi2(i, j)
8692  end do
8693  vipi = vipi + cs(j)*u
8694  end do
8695  return
8696  end function vipi
8697  ! *******************************************************************
8698  ! FUNCTION viii(k)
8699  ! the integral V(2*t3+1,2*t2+1,2*t1+1,thet) in table 76
8700  ! sum with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1) (table 77-b-2)
8701  ! *******************************************************************
8702  function viii(k)
8703  implicit real *8(a-h, o-z)
8704  common /rms/rms(3, 50), s1, s2, s3
8705  common /gauss1/absg(40), wg(40), igaus
8706  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
8707  common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
8708  common /expmod/ragp(40, 100), ragm1(40, 40)
8709  common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)
8710 
8711  viii = 0.
8712  do j = 1, igaus
8713  u = 0.
8714  do i = 1, igaus
8715  u = u + arss(i, j)*ragm1(i, k)*epsi2(i, j)
8716  end do
8717  viii = viii + cs(j)*u
8718  end do
8719  return
8720  end function viii
8721  ! *******************************************************************
8722  ! SUBROUTINE pintfast
8723  ! Particles too far from the C. of G. of the bunch are eliminated
8724  ! for the Almn computations with HERSC
8725  ! *******************************************************************
8726  subroutine pintfast
8727  implicit real *8(a-h, o-z)
8728  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
8729  common /faisc/f(10, iptsz), imax, ngood
8730  common /consta/vl, pi, xmat, rpel, qst
8731  common /dyn/tref, vref
8732  common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
8733  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
8734  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
8735  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
8736  common /nume/nuelm
8737  common /vpintim/gcg, bcg
8738  common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
8739  common /macro/ratei
8740 
8741  nuelm = nuelm + 1
8742  write (16, *) ' space charge with HERSC call number: ', nuelm
8743  trmoy = 0.
8744  wcg = 0.
8745  xcg = 0.
8746  xcg = 0.
8747  ycg = 0.
8748  do i = 1, ngood
8749  trmoy = trmoy + f(6, i)
8750  wcg = wcg + f(7, i)
8751  xcg = xcg + f(2, i)
8752  ycg = ycg + f(4, i)
8753  end do
8754  trmoy = trmoy/float(ngood)
8755  wcg = wcg/float(ngood)
8756  gcg = wcg/xmat
8757  bcg = sqrt(1.-1./(gcg*gcg))
8758  xcg = xcg/float(ngood)
8759  ycg = ycg/float(ngood)
8760  zcg = trmoy*fh
8761  ! Isochronism correction in bending magnet
8762  ! apl is the angle due to the lack of isochronicity in the plane (x,z)
8763  ! (see : A modified space charge routine for high intensity bunched
8764  ! beam,P.Lapostolle and 5 authors,NIM A Vol.379,pp21-40,
8765  ! September 1996)
8766  ! does not work with SCHEFF method (iscsp=3)
8767  apl = 0.
8768  if (iscsp<=2) then
8769  xb2x = 0.
8770  xb2z = 0.
8771  xbxz = 0.
8772  imaxx = 0
8773  do np = 1, ngood
8774  gnp = f(7, np)/xmat
8775  bnp = sqrt(1.-1./(gnp*gnp))
8776  zc(np) = (trmoy-f(6,np))*bnp*vl/100.
8777  ! * correct. relativiste
8778  ! omment zc(np)=zc(np)*gcg
8779  ! *
8780  xc(np) = (f(2,np)-xcg)/100.
8781  xb2z = xb2z + zc(np)*zc(np)
8782  xb2x = xb2x + xc(np)*xc(np)
8783  xbxz = xbxz + zc(np)*xc(np)
8784  imaxx = imaxx + 1
8785  end do
8786  xb2z = xb2z/float(imaxx)
8787  xb2x = xb2x/float(imaxx)
8788  xbxz = xbxz/float(imaxx)
8789  apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
8790  end if
8791  write (16, *) '*slope of the bunch in plane(Oz,Ox):', apl, ' radian'
8792  ! bunch at the space charge position
8793  xbar = 0.
8794  ybar = 0.
8795  zbar = 0.
8796  imaxx = 0
8797  ! Divide by 100. to convert from centimeters to meters
8798  do np = 1, ngood
8799  gnp = f(7, np)/xmat
8800  bnp = sqrt(1.-1./(gnp*gnp))
8801  znp = (trmoy-f(6,np))*bnp*vl
8802  ! * correct. relativiste valero
8803  ! omment znp=znp*gcg
8804  ! *
8805  xnp = f(2, np)
8806  zc(np) = znp*cos(apl) + xnp*sin(apl)
8807  xnp = xnp*cos(apl) - znp*sin(apl)
8808  ! convert from mrad to rad
8809  f3 = f(3, np)*1.e-03
8810  f5 = f(5, np)*1.e-03
8811  ! convert from cm to m
8812  xc(np) = (xnp+zc(np)*f3)/100.
8813  yc(np) = (f(4,np)+zc(np)*f5)/100.
8814  zc(np) = zc(np)/100.
8815  ! evaluate xbar , ybar , zbar
8816  xbar = xbar + xc(np)
8817  ybar = ybar + yc(np)
8818  zbar = zbar + zc(np)
8819  end do
8820  eng = float(ngood)
8821  xbar = xbar/eng
8822  ybar = ybar/eng
8823  zbar = zbar/eng
8824  do np = 1, ngood
8825  xc(np) = xc(np) - xbar
8826  yc(np) = yc(np) - ybar
8827  zc(np) = zc(np) - zbar
8828  end do
8829  return
8830  end subroutine pintfast
8831  ! *******************************************************************
8832  ! SUBROUTINE hcoef
8833  ! the significant Hermite coefficients (called by HERSC)
8834  ! *******************************************************************
8835  subroutine hcoef
8836  implicit real *8(a-h, o-z)
8837  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
8838  common /faisc/f(10, iptsz), imax, ngood
8839  common /consta/vl, pi, xmat, rpel, qst
8840  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
8841  common /hcgrms/xcdg, ycdg, zcdg, ect, eps
8842  common /ind/lmax, mmax, nmax
8843  common /indttal/lmnt
8844  common /randu/ck(15), kmax
8845  common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
8846  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
8847  common /isoch/apl
8848  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
8849  common /nume/nuelm
8850  common /macro/ratei
8851  common /facrms/fxrms, fyrms, fzrms
8852  common /rcoef/rdcf
8853  common /factor/fpir(40, 40), fect(30)
8854  dimension hx(30), hy(30), hz(30), tran(1)
8855  ! calculation of Hermite coefficients on the principal axis in x,y,z
8856  do i = 1, ngood
8857  zcp(i) = zc(i)
8858  xcp(i) = xc(i)
8859  ycp(i) = yc(i)
8860  end do
8861  do kn = 1, nmax
8862  do km = 1, mmax
8863  do kl = 1, lmax
8864  a(kl, km, kn) = 0.
8865  end do
8866  end do
8867  end do
8868  zcg = 0.
8869  xcg = 0.
8870  ycg = 0.
8871  do i = 1, ngood
8872  zcg = zcg + zc(i)
8873  xcg = xcg + xc(i)
8874  ycg = ycg + yc(i)
8875  end do
8876  xcg = xcg/float(ngood)
8877  ycg = ycg/float(ngood)
8878  zcg = zcg/float(ngood)
8879  xsqsum = 0.
8880  ysqsum = 0.
8881  zsqsum = 0.
8882  ! evaluate the rms sizes
8883  do j = 1, ngood
8884  xcj = xc(j) - xcg
8885  ycj = yc(j) - ycg
8886  zcj = zc(j) - zcg
8887  xsqsum = xsqsum + xcj*xcj
8888  ysqsum = ysqsum + ycj*ycj
8889  zsqsum = zsqsum + zcj*zcj
8890  end do
8891  xrmsz = xsqsum/float(ngood)
8892  yrmsz = ysqsum/float(ngood)
8893  zrmsz = zsqsum/float(ngood)
8894  xrmsz = sqrt(xrmsz)
8895  yrmsz = sqrt(yrmsz)
8896  zrmsz = sqrt(zrmsz)
8897  write (16, *) '*RMS of the bunch (m): ', xrmsz, yrmsz, zrmsz
8898  ! omment write(17,25) nuelm,xrmsz,yrmsz,zrmsz
8899  ! omment25 format(2x,i5,3(2x,e12.5))
8900  ! ***TEST control s.c.
8901  ! omment rewind(19)
8902  ! omment irep=0
8903  ! omment rewind(21)
8904  ! omment write(21,*) ' x(cm) y(cm) z(cm)'
8905  ! coordinates of the bunch x, y, z
8906  ! omment do j=1,ngood
8907  ! omment xcoup=(xcp(j)-xcg)/xrmsz
8908  ! omment ycoup=(ycp(j)-ycg)/yrmsz
8909  ! omment zcoup=(zcp(j)-zcg)/zrmsz
8910  ! omment write(21,1188) xcoup,ycoup,zcoup
8911  ! omment if((abs(xcoup).lt.fxrms).and.(abs(ycoup).lt.fyrms).and.
8912  ! omment * (abs(zcoup).lt.fzrms)) then
8913  ! omment write(19,1188) xcoup,ycoup,zcoup
8914  ! omment irep=irep+1
8915  ! omment endif
8916  ! omment enddo
8917  ! omment1188 format(3(2x,e12.5))
8918  ! ***END TEST control s.c.
8919  if (rdcf>=1.) then
8920  hz(1) = 1.
8921  hy(1) = 1.
8922  hx(1) = 1.
8923  irct = 0
8924  do j = 1, ngood
8925  xc(j) = (xcp(j)-xcg)/xrmsz
8926  yc(j) = (ycp(j)-ycg)/yrmsz
8927  zc(j) = (zcp(j)-zcg)/zrmsz
8928  if ((abs(xc(j))<fxrms) .and. (abs(yc(j))<fyrms) .and. (abs(zc(j))<fzrms)) then
8929  irct = irct + 1
8930  ach = abs(f(9,j))
8931  hz(2) = zc(j)
8932  hy(2) = yc(j)
8933  hx(2) = xc(j)
8934  do kn = 1, nmax
8935  if (kn>2) hz(kn) = zc(j)*hz(kn-1) - float(kn-2)*hz(kn-2)
8936  do km = 1, mmax
8937  if (km>2) hy(km) = yc(j)*hy(km-1) - float(km-2)*hy(km-2)
8938  do kl = 1, lmax
8939  if (kl>2) hx(kl) = xc(j)*hx(kl-1) - float(kl-2)*hx(kl-2)
8940  xherm = hx(kl)*hy(km)*hz(kn)/(fect(kl)*fect(km)*fect(kn))
8941  a(kl, km, kn) = a(kl, km, kn) + xherm/pwtpi*ach
8942  end do
8943  end do
8944  end do
8945  end if
8946  end do
8947  rate = float(ngood)/float(irct)
8948  ! write(16,*) ' particles kept in Almn computation: ',irct
8949  do kn = 1, nmax
8950  do km = 1, mmax
8951  do kl = 1, lmax
8952  a(kl, km, kn) = a(kl, km, kn)*rate
8953  end do
8954  end do
8955  end do
8956  end if
8957  ! *********************************
8958  if (rdcf<1.) then
8959  rdcfc = rdcf*float(imax)/float(ngood)
8960  if (rdcfc>1.) rdcfc = 1.
8961  len = 1
8962  irct = 0
8963  hz(1) = 1.
8964  hy(1) = 1.
8965  hx(1) = 1.
8966  do j = 1, ngood
8967  call rlux(tran, len)
8968  if (tran(1)<=rdcfc) then
8969  xc(j) = (xcp(j)-xcg)/xrmsz
8970  yc(j) = (ycp(j)-ycg)/yrmsz
8971  zc(j) = (zcp(j)-zcg)/zrmsz
8972  if ((abs(xc(j))<fxrms) .and. (abs(yc(j))<=fyrms) .and. (abs(zc(j))<fzrms)) then
8973  ach = abs(f(9,j))
8974  irct = irct + 1
8975  hz(2) = zc(j)
8976  hy(2) = yc(j)
8977  hx(2) = xc(j)
8978  do kn = 1, nmax
8979  if (kn>2) hz(kn) = zc(j)*hz(kn-1) - float(kn-2)*hz(kn-2)
8980  do km = 1, mmax
8981  if (km>2) hy(km) = yc(j)*hy(km-1) - float(km-2)*hy(km-2)
8982  do kl = 1, lmax
8983  if (kl>2) hx(kl) = xc(j)*hx(kl-1) - float(kl-2)*hx(kl-2)
8984  xherm = hx(kl)*hy(km)*hz(kn)/(fect(kl)*fect(km)*fect(kn))
8985  a(kl, km, kn) = a(kl, km, kn) + xherm/pwtpi*ach
8986  end do
8987  end do
8988  end do
8989  end if
8990  end if
8991  end do
8992  rate = float(ngood)/float(irct)
8993  write (16, *) ' particles kept in Almn: ', irct
8994  do kn = 1, nmax
8995  do km = 1, mmax
8996  do kl = 1, lmax
8997  a(kl, km, kn) = a(kl, km, kn)*rate
8998  end do
8999  end do
9000  end do
9001  end if
9002  ! 118 format(3(2x,e12.5))
9003  ! * cesaro transformation
9004  lsup = lmax
9005  msup = mmax
9006  nsup = nmax
9007  do kn = 1, nsup
9008  do km = 1, msup
9009  do kl = 1, lsup
9010  cesl = (1.-float(kl-1)/float(lsup))
9011  cesm = (1.-float(km-1)/float(msup))
9012  cesn = (1.-float(kn-1)/float(nsup))
9013  ces = cesl*cesm*cesn
9014  ! esaro force a(kl,km,kn)=a(kl,km,kn)*ces*ces
9015  a(kl, km, kn) = a(kl, km, kn)*ces
9016  end do
9017  end do
9018  end do
9019  ! *
9020  ! select the significant coefficients
9021  ! 999 continue
9022  fond = abs(a(1,1,1))
9023  itot = 0
9024  iret = 0
9025  do kn = 1, nmax
9026  n = kn - 1
9027  ipar = n - 2*int(n/2)
9028  if (ipar==0) zz = 0.
9029  if (ipar/=0) then
9030  if (n==1) zz = 1.
9031  if (n==3) zz = .75
9032  if (n==5) zz = .625
9033  if (n>5 .and. n<=11) zz = 0.50
9034  if (n>11) zz = 0.375
9035  end if
9036  do km = 1, mmax
9037  m = km - 1
9038  ipar = m - 2*int(m/2)
9039  if (ipar==0) yy = 0.
9040  if (ipar/=0) then
9041  if (m==1) yy = 1.
9042  if (m==3) yy = .75
9043  if (m==5) yy = .625
9044  if (m>5 .and. m<=11) yy = 0.50
9045  if (m>11) yy = 0.375
9046  end if
9047  do kl = 1, lmax
9048  l = kl - 1
9049  ipar = l - 2*int(l/2)
9050  if (ipar==0) xx = 0.
9051  if (ipar/=0) then
9052  if (l==1) xx = 1.
9053  if (l==3) xx = .75
9054  if (l==5) xx = .625
9055  if (l>5 .and. l<=11) xx = 0.50
9056  if (l>11) xx = 0.375
9057  end if
9058  itot = itot + 1
9059  xherm = hermint(xx, l)*hermint(yy, m)*hermint(zz, n)
9060  ab = abs(a(kl,km,kn)*xherm)/fond
9061  if (ab>=eps) then
9062  iret = iret + 1
9063  else
9064  a(kl, km, kn) = 0.
9065  end if
9066  end do
9067  end do
9068  end do
9069  rpeps = float(iret)/float(itot)
9070  write (16, *) '*significant terms in Hermite series expansion: ', iret, ' total of terms :', itot
9071  if (rpeps>=.3) then
9072  write (16, *) ' problem in space charge : rpeps gt .3 ', rpeps
9073  stop
9074  end if
9075  ! select the maximum values l, m and n for the significant coefficients
9076  lsup = 0
9077  msup = 0
9078  nsup = 0
9079  lmnt = 0
9080  do kn = 1, nmax
9081  do km = 1, mmax
9082  do kl = 1, lmax
9083  if (a(kl,km,kn)/=0.) then
9084  itm = kl + km + kn - 3
9085  if (itm>=lmnt) lmnt = itm
9086  if (lsup<=kl) lsup = kl
9087  if (msup<=km) msup = km
9088  if (nsup<=kn) nsup = kn
9089  end if
9090  end do
9091  end do
9092  end do
9093  lmnt = lmnt + kmax + 4 + 3
9094  write (16, *) ' maximum of n m l for the significants terms ', nsup - 1, msup - 1, lsup - 1
9095  write (16, *) ' maximun of (t) for the significants terms ', lmnt
9096  ! * cesaro transformation
9097  ! cc do kn=1,nsup
9098  ! cc do km=1,msup
9099  ! cc do kl=1,lsup
9100  ! cc cesl=(1.-float(kl-1)/float(lsup))
9101  ! cc cesm=(1.-float(km-1)/float(msup))
9102  ! cc cesn=(1.-float(kn-1)/float(nsup))
9103  ! cc ces=cesl*cesm*cesn
9104  ! cc a(kl,km,kn)=a(kl,km,kn)*ces
9105  ! cc enddo
9106  ! cc enddo
9107  ! cc enddo
9108  ! *
9109  return
9110  end subroutine hcoef
9111  ! *******************************************************************
9112  ! SUBROUTINE hersc(ini)
9113  ! space charge method: HERSC
9114  ! *******************************************************************
9115  subroutine hersc(ini)
9116  implicit real *8(a-h, o-z)
9117  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
9118  common /faisc/f(10, iptsz), imax, ngood
9119  common /consta/vl, pi, xmat, rpel, qst
9120  common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
9121  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
9122  common /cdek/dwp(iptsz)
9123  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
9124  common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
9125  common /hcgrms/xcdg, ycdg, zcdg, ect, eps
9126  common /ind/lmax, mmax, nmax
9127  common /indin/lmaxi, mmaxi, nmaxxi
9128  common /indttal/lmnt
9129  common /rms/rms(3, 50), s1, s2, s3
9130  common /randu/ck(15), kmax
9131  common /circu/co(40, 50), sn(40, 50), blam(40, 100)
9132  common /gauss1/absg(40), wg(40), igaus
9133  common /field/ex, ey, ez
9134  common /expmod/ragp(40, 100), ragm1(40, 40)
9135  common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
9136  common /facrms/fxrms, fyrms, fzrms
9137  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
9138  common /beamsa/fs(7, iptsz)
9139  common /dcspa/iesp
9140  common /cmpte/iell
9141  common /npart/imaxr
9142  common /compt/nrres, nrtre, nrbunc, nrdbun
9143  common /rcoef/rdcf
9144  common /macro/ratei
9145  common /tapes/in, ifile, meta
9146  common /posc/xpsc
9147  common /locher/rx, ry, rz, nx, ny, nz
9148  logical ichaes, iesp
9149  dimension exk(15, 15, 30), eyk(15, 15, 30), ezk(15, 15, 30)
9150  data lbmax, mbmax, nbmax/23, 23, 23/
9151  ! ini = 0 :initialisation of the routine
9152  if (ini<=0) then
9153  sq2pi = sqrt(2.*pi)
9154  ! input parameters
9155  igaus = 9
9156  ! eps allows to select the significant terms in the HERMITE series expansion
9157  eps = 8.e-03
9158  ! maximun of the upper limits in the HERMITE series expansion
9159  lmaxi = 11
9160  mmaxi = 11
9161  nmaxxi = 11
9162  ! The HERMITE coefficients Almn are computed with the particles include in a cube
9163  ! with regard to the RMS of the bunch. The sizes of the cube are:RMSx*fxrms, ........
9164  fxrms = 2.5
9165  fyrms = 2.5
9166  fzrms = 2.5
9167  if (ini<0) then
9168  read (in, *) lmaxi, mmaxi, nmaxxi
9169  write (16, *) 'upper limits ', lmaxi, mmaxi, nmaxxi
9170  read (in, *) fxrms, fyrms, fzrms
9171  write (16, *) ' rms factors', fxrms, fyrms, fzrms
9172  read (in, *) eps
9173  write (16, *) ' select the Hermite cefficients with: ', eps
9174  end if
9175  ! MESH**********
9176  ! limits in (+-) RMS
9177  rx = 4.
9178  ry = 4.
9179  rz = 4.
9180  ! number of nodes in each direction
9181  nx = 8
9182  ny = 8
9183  nz = 8
9184  ! rdcf : in %/100 , allows to select a reduced number of particles for the Almn.
9185  call shuffle
9186  call gausse
9187  read (in, *) rdcf
9188  if (rdcf>1.) rdcf = 1.
9189  if (rdcf<=0.) then
9190  if (ngood>15000) then
9191  rdcf = 15000./float(ngood)
9192  else
9193  rdcf = 1.
9194  end if
9195  end if
9196  call table(lbmax, mbmax, nbmax)
9197  return
9198  end if
9199  ! **********************************************************************
9200  if (ini==1) then
9201  ! .................................................................................
9202  ! seeks: the significant coefficients in the Hermite series expansions
9203  ! ---> storage array a(l,m,n)
9204  ! maximum values of l,m and n of the significants a(l,m,n) --->lmax,mmax,nmax
9205  ! RMS of the bunch ---> xa,xb and xc
9206  ! order of the succesives integrals
9207  ! isucc=1: xa<xb,xc , rms(3,2)=xa, rms(2,2)=xb, rms(1,2)=xc
9208  ! rms(3,k)=xa**(k-1), ..........
9209  ! isucc=2: xb<xa,xc , rms(3,2)=xb, rms(2,2)=xc, rms(1,2)=xa
9210  ! isucc=1: xc<xa,xb , rms(3,2)=xc, rms(2,2)=xa, rms(1,2)=xb
9211  ! compute the array blam(i,j)
9212  ! blam(i,j): FUNCTION beta**2 in the fifth relation in table 31
9213  ! blam(i,j)=beta**2j,j=1,...,im=(lmax+mmax+nmax+kmax)/2+2
9214  ! i is given from the i-Gauss position in absg(i)
9215  ! ..................................................................................
9216  call bhdist
9217  call trms(isucc)
9218  sta = a(1, 1, 1)
9219  icoa = 0
9220  do ican = 1, nmax
9221  do icam = 1, mmax
9222  do ical = 1, lmax
9223  if (a(ican,icam,ical)/=0.) icoa = icoa + 1
9224  end do
9225  end do
9226  end do
9227  return
9228  end if
9229  ! **********************************************************************
9230  ! beam self-fields
9231  if (ini==2) then
9232  ! limits of the mesch : rx ry rz
9233  ! length of the steps
9234  delx = 2.*rx/float(nx)
9235  dely = 2.*ry/float(ny)
9236  delz = 2.*rz/float(nz)
9237  ! Initialize constants
9238  ! xmass-Kg,wavel=cm,charge=coul.
9239  ! clight=cm/sec MHz/Hz ,freq=Mhz ,xmat=MeV
9240  ! freq. in MHz
9241  freq = fh*0.5e-06/pi
9242  epsilon = 8.854189586e-12
9243  const3 = 1.e-06
9244  const2 = 1.e-06/xmat
9245  dxp = 0.
9246  dyp = 0.
9247  dw = 0.
9248  dz = scdist/100.
9249  dz1 = dz
9250  zsot1 = 0.
9251  ! qmpart=macro-charge
9252  qmpart = 1.0e-9*beamc/(float(imax)*freq)
9253  if (ratei<=0.) then
9254  write (16, *) ' all the particles are lost '
9255  stop
9256  end if
9257  qmpart = qmpart*ratei
9258  vrms = xrmsz*yrmsz*zrmsz
9259  cmacro = qmpart/(epsilon*vrms)
9260  wcg = 0.
9261  do i = 1, ngood
9262  wcg = wcg + f(7, i)
9263  end do
9264  wcg = wcg/float(ngood)
9265  gcg = wcg/xmat
9266  gmoy = gcg
9267  bcg = sqrt(1.-1./(gcg*gcg))
9268  bmoy = bcg
9269  ! relativistic correction
9270  cmacro = cmacro/gmoy
9271 
9272  cmacrxy = cmacro/(bmoy*bmoy*gmoy*gmoy)
9273  ! beam self-fields at the nodes of the mesh
9274  imail = 0
9275  rcy = -ry
9276  do j = 1, ny
9277  rcx = -rx
9278  do i = 1, nx
9279  rcz = -rz
9280  do k = 1, nz
9281  if (isucc==1) then
9282  s3 = rcx
9283  s2 = rcy
9284  s1 = rcz
9285  ax = pwtpi*rms(3, 2)
9286  ay = pwtpi*rms(2, 2)
9287  az = pwtpi*rms(1, 2)
9288  rrx = rms(3, 2)
9289  rry = rms(2, 2)
9290  rrz = rms(1, 2)
9291  end if
9292  if (isucc==2) then
9293  s3 = rcy
9294  s2 = rcz
9295  s1 = rcx
9296  ax = pwtpi*rms(1, 2)
9297  ay = pwtpi*rms(3, 2)
9298  az = pwtpi*rms(2, 2)
9299  rrx = rms(1, 2)
9300  rry = rms(3, 2)
9301  rrz = rms(2, 2)
9302  end if
9303  if (isucc==3) then
9304  s3 = rcz
9305  s2 = rcx
9306  s1 = rcy
9307  ax = pwtpi*rms(2, 2)
9308  ay = pwtpi*rms(1, 2)
9309  az = pwtpi*rms(3, 2)
9310  rrx = rms(2, 2)
9311  rry = rms(1, 2)
9312  rrz = rms(3, 2)
9313  end if
9314  call uvrms
9315  ! fields
9316  ! loop over the l,m and n
9317  exk(i, j, k) = 0.
9318  eyk(i, j, k) = 0.
9319  ezk(i, j, k) = 0.
9320  do jn = 1, nmax
9321  jn1 = jn - 1
9322  do jm = 1, mmax
9323  jm1 = jm - 1
9324  do jl = 1, lmax
9325  jl1 = jl - 1
9326  if (a(jl,jm,jn)/=0.) then
9327  call fielde(jl1, jm1, jn1, isucc)
9328  ! the beam self-fields are in tables 67-a to 67-h
9329  exk(i, j, k) = a(jl, jm, jn)/ax*ex + exk(i, j, k)
9330  eyk(i, j, k) = a(jl, jm, jn)/ay*ey + eyk(i, j, k)
9331  ezk(i, j, k) = a(jl, jm, jn)/az*ez + ezk(i, j, k)
9332  end if
9333  end do
9334  end do
9335  end do
9336  rcz = rcz + delz
9337  imail = imail + 1
9338  end do
9339  rcx = rcx + delx
9340  end do
9341  rcy = rcy + dely
9342  end do
9343  ! xi in Amps, ibeam in mA
9344  dxp = 0.
9345  dyp = 0.
9346  dw = 0.
9347  ! save the particles coordinates
9348  do i = 1, ngood
9349  xc(i) = xcp(i)
9350  yc(i) = ycp(i)
9351  zc(i) = zcp(i)
9352  end do
9353  ! Do integration to determine Ex,Ey,Ez for each macro particle
9354  nprint = 1
9355  insd = 0
9356  iout = 0
9357  ickl = 0
9358  do ic = 1, ngood
9359  ! position in the mesh
9360  ickl = ickl + 1
9361  ! * valero
9362  u = xc(ic)/xrmsz
9363  v = yc(ic)/yrmsz
9364  w = zc(ic)/zrmsz
9365  ! omment u=xc(ic)/rrx
9366  ! omment v=yc(ic)/rry
9367  ! omment w=zc(ic)/rrz
9368  i = int((u+rx)/delx) + 1
9369  j = int((v+ry)/dely) + 1
9370  k = int((w+rz)/delz) + 1
9371  ! the particle is in the mesh
9372  if (i>0 .and. i<=nx .and. j>0 .and. j<=ny .and. k>0 .and. k<=nz) then
9373  xnd1 = -rx + float(i-1)*delx
9374  ynd1 = -ry + float(j-1)*dely
9375  znd1 = -rz + float(k-1)*delz
9376  delu = u - xnd1
9377  delv = v - ynd1
9378  delw = w - znd1
9379  delux = delu/delx
9380  delvy = delv/dely
9381  delwz = delw/delz
9382  ! *******interpollation for particle inside a cube
9383  ! %%%%%% in plane 1:
9384  ! node 1: (i,j,k) node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 4:(i,j,k+1)
9385  ! axis (nd1,nd2)
9386  ex12 = (exk(i+1,j,k)-exk(i,j,k))*delux + exk(i, j, k)
9387  ! axis (nd4,nd3)
9388  ex43 = (exk(i+1,j,k+1)-exk(i,j,k+1))*delux + exk(i, j, k+1)
9389  ! plane 1
9390  exp1 = (ex43-ex12)*delwz + ex12
9391  ! %%%%%%% in plane 3:
9392  ! node 5:(i,j+1,k) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1) node 8:(i,j+1,k+1)
9393  ! axis(nd5,nd6)
9394  ex56 = (exk(i+1,j+1,k)-exk(i,j+1,k))*delux + exk(i, j+1, k)
9395  ! axis(nd8,nd7)
9396  ex87 = (exk(i+1,j+1,k+1)-exk(i,j+1,k+1))*delux + exk(i, j+1, k+1)
9397  ! plane 3
9398  exp3 = (ex87-ex56)*delwz + ex56
9399  ! $$$$$ plane1+plane3
9400  exp13 = (exp3-exp1)*delvy + exp1
9401  ! %%%%% in plane 2:
9402  ! node 1: (i,j,k) node 2:(i+1,j,k) node 5:(i,j+1,k) node 6:(i+1,j+1,k)
9403  ! axis (nd1,nd2) : ex12
9404  ! axis (nd5,nd6) : ex56
9405  ! plane 2
9406  exp2 = (ex56-ex12)*delvy + ex12
9407  ! %%%%%% in plane 5
9408  ! node 4:(i,j,k+1) node 3:(i+1,j,k+1) node 8:(i,j+1,k+1) node 7:(i+1,j+1,k+1)
9409  ! axis(nd4,nd3)
9410  ex43 = (exk(i+1,j,k+1)-exk(i,j,k+1))*delux + exk(i, j, k+1)
9411  ! axis(nd8,nd7)
9412  ex87 = (exk(i+1,j+1,k+1)-exk(i,j+1,k+1))*delux + exk(i, j+1, k+1)
9413  ! plane 5
9414  exp5 = (ex87-ex43)*delvy + ex43
9415  ! $$$$ plane2+plane5
9416  exp25 = (exp5-exp2)*delwz + exp2
9417  ! &&&& (plane1+plane3)+(plane2+plane5) --> field Ex(u,v,w)
9418  ext = (exp13+exp25)/2.
9419  ! ******* field component Ey
9420  ! %%%%%% in plane 2:
9421  ! node 1: (i,j,k) node 2:(i+1,j,k) node 5:(i,j+1,k) node 6:(i+1,j+1,k)
9422  ! axis(nd1,nd5)
9423  ey15 = (eyk(i,j+1,k)-eyk(i,j,k))*delvy + eyk(i, j, k)
9424  ! axis (nd2,nd6)
9425  ey26 = (eyk(i+1,j+1,k)-eyk(i+1,j,k))*delvy + eyk(i+1, j, k)
9426  ! plane 2
9427  eyp2 = (ey26-ey15)*delu/delx + ey15
9428  ! %%%%%% in plane 5:
9429  ! node 4:(i,j,k+1) node 3:(i+1,j,k+1) node 8:(i,j+1,k+1) node 7:(i+1,j+1,k+1)
9430  ! axis(nd4,nd8)
9431  ey48 = (eyk(i,j+1,k+1)-eyk(i,j,k+1))*delvy + eyk(i, j, k+1)
9432  ! axis(nd3,nd7)
9433  ey37 = (eyk(i+1,j+1,k+1)-eyk(i+1,j,k+1))*delvy + eyk(i+1, j, k+1)
9434  ! plane 5
9435  eyp5 = (ey37-ey48)*delux + ey48
9436  ! $$$$$$ plane2+plane5
9437  eyp25 = (eyp5-eyp2)*delwz + eyp2
9438  ! %%%%%% in plane 6:
9439  ! node 1:(i,j,k) node 5:(i,j+1,k) node 4:(i,j,k+1) node 8:(i,j+1,k+1)
9440  ! axis(nd1,nd5): ey15
9441  ! axis(nd4,nd8): ey48
9442  ! plane 6
9443  eyp6 = (ey48-ey15)*delwz + ey15
9444  ! %%%%%% in plane 4:
9445  ! node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1)
9446  ! axis(nd2,nd6): ey26
9447  ! axis(nd3,nd7): ey37
9448  ! plane 4
9449  eyp4 = (ey37-ey26)*delwz + ey26
9450  ! $$$$plane6+plane4
9451  eyp46 = (eyp4-eyp6)*delux + eyp6
9452  ! £££ (plane2+plane5)+(plane4+plane6)--> field Ez(u,v,w)
9453  eyt = (eyp25+eyp46)/2.
9454  ! *******interpollation of the field component Ez
9455  ! %%%%%% in plane 1:
9456  ! node 1:(i,j,k) node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 4:(i,j,k+1)
9457  ! axis(nd1,nd4)
9458  ez14 = (ezk(i,j,k+1)-ezk(i,j,k))*delwz + ezk(i, j, k)
9459  ! axis(nd2,nd3)
9460  ez23 = (ezk(i+1,j,k+1)-ezk(i+1,j,k))*delwz + ezk(i+1, j, k)
9461  ! plane 1
9462  ezp1 = (ez23-ez14)*delux + ez14
9463  ! %%%%%% in plane 3:
9464  ! node 5:(i,j+1,k) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1) node 8:(i,j+1,k+1)
9465  ! axis (nd5,nd8)
9466  ez58 = (ezk(i,j+1,k+1)-ezk(i,j+1,k))*delwz + ezk(i, j+1, k)
9467  ! axis (nd6,nd7)
9468  ez67 = (ezk(i+1,j+1,k+1)-ezk(i+1,j+1,k))*delwz + ezk(i+1, j+1, k)
9469  ! plane 3
9470  ezp3 = (ez67-ez58)*delux + ez58
9471  ! $$$$$$ plane1+plane3
9472  ezp13 = (ezp3-ezp1)*delvy + ezp1
9473  ! %%%%%% in plane 6:
9474  ! node 1:(i,j,k) node 5:(i,j+1,k) node 4:(i,j,k+1) node 8:(i,j+1,k+1)
9475  ! axis (nd1,nd4)
9476  ez14 = (ezk(i,j,k+1)-ezk(i,j,k))*delwz + ezk(i, j, k)
9477  ! axis (nd5,nd8)
9478  ez58 = (ezk(i,j+1,k+1)-ezk(i,j+1,k))*delwz + ezk(i, j+1, k)
9479  ! plane 6
9480  ezp6 = (ez58-ez14)*delvy + ez14
9481  ! %%%%%% in plane 4:
9482  ! node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1)
9483  ! axis(nd2,nd3)
9484  ez23 = (ezk(i+1,j,k+1)-ezk(i+1,j,k))*delwz + ezk(i+1, j, k)
9485  ! axis(nd6,nd7)
9486  ez67 = (ezk(i+1,j+1,k+1)-ezk(i+1,j+1,k))*delwz + ezk(i+1, j+1, k)
9487  ! plane 4
9488  ezp4 = (ez67-ez23)*delvy + ez23
9489  ! $$$$$$ plane6+plane4
9490  ezp64 = (ezp4-ezp6)*delux + ezp6
9491  ! £££££££ (P1+P3)+(P6+P4)----> Ez(u,v,w)
9492  ezt = (ezp13+ezp64)/2.
9493  insd = insd + 1
9494  ! calculate kicks in x',y' and z' (energy)
9495  eztp = ezt*cos(apl) - ext*sin(apl)
9496  extp = ezt*sin(apl) + ext*cos(apl)
9497  ezt = eztp
9498  ext = extp
9499  gsc = f(7, ic)/xmat
9500  bsc = sqrt(1.-1./(gsc*gsc))
9501  ! omment cmacrxy=cmacro/(bmoy*bmoy*gmoy*gmoy*gmoy)
9502  ! omment cmacrxy=cmacro/(bsc*bsc*gsc*gsc)
9503  dxp = const2*ext*dz*cmacrxy*abs(f(9,ic))
9504  dyp = const2*eyt*dz*cmacrxy*abs(f(9,ic))
9505  dw = const3*ezt*dz*cmacro*abs(f(9,ic))
9506  ! ****test************************************
9507  ! omment dw=dw/gmoy
9508  ! ****************************************
9509  if (.not. iesp) then
9510  ! load the entrance beam parameters for cavities or gaps
9511  do js = 1, 7
9512  f(js, ic) = fs(js, ic)
9513  end do
9514  f(3, ic) = f(3, ic) + dxp*1000.
9515  f(5, ic) = f(5, ic) + dyp*1000.
9516  f(2, ic) = f(2, ic) - dz1*dxp*100.*xpsc
9517  f(4, ic) = f(4, ic) - dz1*dyp*100.*xpsc
9518  ! omment f(2,ic)=f(2,ic)-dz1*dxp*100.
9519  ! omment f(4,ic)=f(4,ic)-dz1*dyp*100.
9520  dwp(ic) = dw
9521  else
9522  f(3, ic) = f(3, ic) + dxp*1000.
9523  f(5, ic) = f(5, ic) + dyp*1000.
9524  f(7, ic) = f(7, ic) + dw
9525  end if
9526  else
9527  ! the particle is not in the mesh
9528  ! computed the beam self-fields as made at the nodes
9529  ax = 0.
9530  ay = 0.
9531  az = 0.
9532  if (isucc==1) then
9533  s3 = xc(ic)/rms(3, 2)
9534  s2 = yc(ic)/rms(2, 2)
9535  s1 = zc(ic)/rms(1, 2)
9536  ax = pwtpi*rms(3, 2)
9537  ay = pwtpi*rms(2, 2)
9538  az = pwtpi*rms(1, 2)
9539  rrx = rms(3, 2)
9540  rry = rms(2, 2)
9541  rrz = rms(1, 2)
9542  end if
9543  if (isucc==2) then
9544  s3 = yc(ic)/rms(3, 2)
9545  s2 = zc(ic)/rms(2, 2)
9546  s1 = xc(ic)/rms(1, 2)
9547  ax = pwtpi*rms(1, 2)
9548  ay = pwtpi*rms(3, 2)
9549  az = pwtpi*rms(2, 2)
9550  rrx = rms(1, 2)
9551  rry = rms(3, 2)
9552  rrz = rms(2, 2)
9553  end if
9554  if (isucc==3) then
9555  s3 = zc(ic)/rms(3, 2)
9556  s2 = xc(ic)/rms(2, 2)
9557  s1 = yc(ic)/rms(1, 2)
9558  ax = pwtpi*rms(2, 2)
9559  ay = pwtpi*rms(1, 2)
9560  az = pwtpi*rms(3, 2)
9561  rrx = rms(2, 2)
9562  rry = rms(1, 2)
9563  rrz = rms(3, 2)
9564  end if
9565  ! storage arrays of the functions in the integrals in tables 75 and 76
9566  ! these values given in table 73 are independent of l, m and n
9567  ! They are stored in: epsi1(i,j),epsi2(i,j), akpc1(i,j), akpc2(i,j),
9568  ! akps1(i,j), akps2(i,j) where i,j are the Gauss positions
9569  call uvrms
9570  ! field computation
9571  ! loop over the l,m and n
9572  ext = 0.
9573  eyt = 0.
9574  ezt = 0.
9575  do jn = 1, nmax
9576  jn1 = jn - 1
9577  do jm = 1, mmax
9578  jm1 = jm - 1
9579  do jl = 1, lmax
9580  jl1 = jl - 1
9581  if (a(jl,jm,jn)/=0.) then
9582  ! in output the SUBROUTINE field returns the values of the FUNCTION E*(l,m,n)
9583  ! shown in tables 77-a-1 to 77-b-2 in x,y and z-directions-->ex,ey,ez
9584  call fielde(jl1, jm1, jn1, isucc)
9585  ! the corresonding field components are obtained from tables 67-a to 67-h
9586  ext = a(jl, jm, jn)/ax*ex + ext
9587  eyt = a(jl, jm, jn)/ay*ey + eyt
9588  ezt = a(jl, jm, jn)/az*ez + ezt
9589  end if
9590  end do
9591  end do
9592  end do
9593  iout = iout + 1
9594  ! kicks
9595  ! kicks computation
9596  ! calculate kick in x',y' and z' (energy)
9597  ! isochronism correction
9598  eztp = ezt*cos(apl) - ext*sin(apl)
9599  extp = ezt*sin(apl) + ext*cos(apl)
9600  ezt = eztp
9601  ext = extp
9602  gsc = f(7, ic)/xmat
9603  bsc = sqrt(1.-1./(gsc*gsc))
9604  ! omment cmacrxy=cmacro/(bmoy*bmoy*gmoy*gmoy)
9605  ! omment cmacrxy=cmacro/(bsc*bsc*gsc*gsc)
9606  dxp = const2*ext*dz*cmacrxy*abs(f(9,ic))
9607  dyp = const2*eyt*dz*cmacrxy*abs(f(9,ic))
9608  dw = const3*ezt*dz*cmacro*abs(f(9,ic))
9609  if (.not. iesp) then
9610  ! load the beam at the input at cavities or gaps
9611  do js = 1, 7
9612  f(js, ic) = fs(js, ic)
9613  end do
9614  f(3, ic) = f(3, ic) + dxp*1000.
9615  f(5, ic) = f(5, ic) + dyp*1000.
9616  f(2, ic) = f(2, ic) - dz1*dxp*100.*xpsc
9617  f(4, ic) = f(4, ic) - dz1*dyp*100.*xpsc
9618  ! omment f(2,ic)=f(2,ic)-dz1*dxp*100.
9619  ! omment f(4,ic)=f(4,ic)-dz1*dyp*100.
9620  dwp(ic) = dw
9621  else
9622  f(3, ic) = f(3, ic) + dxp*1000.
9623  f(5, ic) = f(5, ic) + dyp*1000.
9624  f(7, ic) = f(7, ic) + dw
9625  end if
9626  end if
9627  ! end of if particle not in mesh
9628  nprint = nprint + 1
9629  ! end of the loop ic
9630  end do
9631  write (16, *) ' particles in the mesh:', insd, ' outside: ', iout
9632  ! end of if when ini=2
9633  end if
9634  ! 1000 format(4(2x,e12.5))
9635  return
9636  end subroutine hersc
9637  ! *******************************************************************
9638  ! SUBROUTINE xtypl1(GAMI,SAPHI,QSC,DCG)
9639  ! called by ETGAP and RESTAY
9640  ! INTEGRALS E(z)*(BG)**-3 *z**n n=0,1
9641  ! INTEGRALS dE(z)/dT*(BG)**-3 *z**n n=0,1,2
9642  ! INTEGRALS FONCTIONS HA0(Z) et HB0(Z)
9643  ! INTEGRALS OF THE FIRST DERIVATIVES OF HA0(Z) et HB0(Z)
9644  ! *******************************************************************
9645  subroutine xtypl1(gami, saphi, qsc, dcg)
9646  implicit real *8(a-h, o-z)
9647  common /consta/vl, pi, xmat, rpel, qst
9648  common /posi/ist
9649  common /jacob/gaks, gaps
9650  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
9651  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
9652  common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
9653  common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
9654  ! TRANSVERSAL dE(z)/dt
9655  common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
9656  common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
9657  dimension h(17), t(17)
9658  data t/ -.990575473, -.950675522, -.880239154, -.781514004, -.657671159, -.512690537, -.351231763, -.178484181, &
9659  0., .178484181, .351231763, .512690537, .657671159, .781514004, .880239154, .950675522, .990575473/
9660  data h/.024148303, .055459529, .085036148, .111883847, .135136368, .154045761, .168004102, .176562705, .179446470, &
9661  .176562705, .168004102, .154045761, .135136368, .111883847, .085036148, .055459529, .024148303/
9662 
9663  fh0 = fh/vl
9664  ! valero 08/08/07
9665  ! omment CGI=ABS(QSC/XMAT)
9666  cgi = qsc/xmat
9667  ! *
9668  ! Circular cosinus functions
9669  ! In longitudinal direction
9670  yh1k0 = 0.
9671  yh1k1 = 0.
9672  yp1k1 = 0.
9673  yp1k2 = 0.
9674  yh1k00 = 0.
9675  yh1k01 = 0.
9676  yp1k01 = 0.
9677  yp1k02 = 0.
9678  yh10 = 0.
9679  yh11 = 0.
9680  yp11 = 0.
9681  yp12 = 0.
9682  ! In transverse direction ( dE(z)/dt )
9683  ye1k0 = 0.
9684  ye1k1 = 0.
9685  ye1k2 = 0.
9686  ye1kc0 = 0.
9687  ye1kc1 = 0.
9688  ye1kc2 = 0.
9689  ye10 = 0.
9690  ye11 = 0.
9691  ye12 = 0.
9692  ! Circular sinus functions
9693  ! In longitudinal direction
9694  yh2k0 = 0.
9695  yh2k1 = 0.
9696  yp2k1 = 0.
9697  yp2k2 = 0.
9698  yh2k00 = 0.
9699  yh2k01 = 0.
9700  yp2k01 = 0.
9701  yp2k02 = 0.
9702  yh20 = 0.
9703  yh21 = 0.
9704  yp21 = 0.
9705  yp22 = 0.
9706  ! In transverse direction ( dE(z)/dt )
9707  ye2k0 = 0.
9708  ye2k1 = 0.
9709  ye2k2 = 0.
9710  ye2kc0 = 0.
9711  ye2kc1 = 0.
9712  ye2kc2 = 0.
9713  ye20 = 0.
9714  ye21 = 0.
9715  ye22 = 0.
9716  ! Calculates the integrals
9717  dtilk = eqvl
9718  gam2 = gami**2
9719  beti = sqrt(1.-1./gam2)
9720  xk1 = fh0/beti
9721  tilta2 = phslip/(2.*eqvl)
9722  cgam10 = ((gami*gami-1.)**1.5)/fh0
9723  phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
9724  ist = 0
9725  do i = 1, 17
9726  ist = ist + 1
9727  xcc = eqvl*(1.+t(i))/2.
9728  xcc1 = xcc + asdl
9729  if (xcc1>dcg) go to 200
9730  phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
9731  ! FONCTION GAMMA (Z)
9732  if (phslip/=0.) then
9733  git = cgi*sqcttf*cos(phit0-pcrest)/phslip
9734  gis = sin(xcc*tilta2)
9735  else
9736  git = cgi*sqcttf*cos(phit0-pcrest)
9737  gis = xcc/(2.*eqvl)
9738  end if
9739  gi = gami + git*gis
9740  bi = sqrt(1.-1./(gi*gi))
9741  ! Derivative of G0(Z) relative to the equivalent k
9742  phit0k = -dtilk*(1.-xcc/eqvl)/2.
9743  if (phslip/=0.) then
9744  gic = cos(xcc*tilta2)
9745  gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
9746  gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
9747  gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
9748  gak = cgi*sqcttf*(-gak1-gak2+gak3)
9749  else
9750  gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
9751  gak = -cgi*sqcttf*gak1
9752  end if
9753  if (i==17) gaks = gak
9754  ! Calculate the integrals of HA0(Z) and HB0(Z)
9755  xint = 1./(bi*bi*bi*gi*gi*gi)
9756  phit1 = phit0 + xcc*phslip/(2.*eqvl)
9757  phtz0 = (xcc/eqvl-.5)*dtilk
9758  ha0 = 2.*sqcttf*cos(phit1-pcrest)*xint
9759  hb0 = 2.*sqcttf*sin(phit1-pcrest)*xint
9760  ! n=0
9761  ! Longitudinal direction
9762  yh10 = yh10 + h(i)*ha0
9763  yh20 = yh20 + h(i)*hb0
9764  ! Transverse direction
9765  ye10 = yh20
9766  ye20 = yh10
9767  ! n=1
9768  ! Longitudinal direction
9769  yh11 = yh11 + h(i)*ha0*xcc1
9770  yh21 = yh21 + h(i)*hb0*xcc1
9771  ! Transverse direction
9772  ye11 = ye11 + h(i)*hb0*xcc
9773  ye21 = ye21 + h(i)*ha0*xcc
9774  ! n=2
9775  ye12 = ye12 + h(i)*hb0*xcc*xcc
9776  ye22 = ye22 + h(i)*ha0*xcc*xcc
9777  ! Calculate the integrals of the derivative of HA0(Z)
9778  dha01 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
9779  dha02 = sqcttf*cos(phit1-pcrest)*gi*gak/((gi*gi-1.)**2.5)
9780  dha03 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
9781  ! n=0
9782  ! Longitudinal direction
9783  yh1k00 = yh1k00 + h(i)*dha01*6.*cgam10
9784  yh1k0 = yh1k0 + h(i)*(-6.*dha02+2.*(phcrtk-phtz0)*dha03)
9785  ! Transverse direction
9786  ye2kc0 = yh1k00
9787  ye2k0 = yh1k0
9788  ! n=1
9789  ! Longitudinal direction
9790  yh1k01 = yh1k01 + h(i)*dha01*xcc1*6.*cgam10
9791  yh1k1 = yh1k1 + h(i)*xcc1*(-6.*dha02+2.*(phcrtk-phtz0)*dha03)
9792  ! Transverse direction
9793  ye2kc1 = ye2kc1 + h(i)*dha01*xcc*6.*cgam10
9794  ye2k1 = ye2k1 + h(i)*xcc*(-6.*dha02-2.*(phcrtk-phtz0)*dha03)
9795  ! n=2
9796  ye2kc2 = ye2kc2 + h(i)*dha01*xcc*xcc*6.*cgam10
9797  ye2k2 = ye2k2 + h(i)*xcc*xcc*(-6.*dha02-2.*(phcrtk-phtz0)*dha03)
9798  ! INTEGRALS Of HB0(Z)
9799  dhb01 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
9800  dhb02 = sqcttf*sin(phit1-pcrest)*gi*gak/((gi*gi-1.)**2.5)
9801  dhb03 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
9802  ! n=0
9803  ! LONGITUDINAL
9804  yh2k00 = yh2k00 + h(i)*dhb01*6.*cgam10
9805  yh2k0 = yh2k0 + h(i)*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9806  ! TRANSVERSE
9807  ye1kc0 = yh2k00
9808  ye1k0 = yh2k0
9809  ! n=1
9810  ! LONGITUDINAL
9811  yh2k01 = yh2k01 + h(i)*dhb01*xcc1*6.*cgam10
9812  yh2k1 = yh2k1 + h(i)*xcc1*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9813  ! TRANSVERSE
9814  ye1kc1 = ye1kc1 + h(i)*dhb01*xcc*6.*cgam10
9815  ye1k1 = ye1k1 + h(i)*xcc*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9816  ! n=2
9817  ye1kc2 = ye1kc2 + h(i)*dhb01*xcc*xcc*6.*cgam10
9818  ye1k2 = ye1k2 + h(i)*xcc*xcc*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
9819  ! Calculate the integrals of PA0(Z) et PB0(Z)
9820  pa0 = 2.*sqcttf*cos(phit1-pcrest)*xint*xint
9821  pb0 = 2.*sqcttf*sin(phit1-pcrest)*xint*xint
9822  ! n=1
9823  yp11 = yp11 + h(i)*pa0*xcc1
9824  yp21 = yp21 + h(i)*pb0*xcc1
9825  ! n=2
9826  yp12 = yp12 + h(i)*pa0*xcc1*xcc1
9827  yp22 = yp22 + h(i)*pb0*xcc1*xcc1
9828  ! Calculate the integrals of the derivatives of PA0(Z)
9829  dpa01 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**4)
9830  dpa02 = sqcttf*cos(phit1-pcrest)*gi*gak/((gi*gi-1.)**4)
9831  dpa03 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**3)
9832  ! n=1
9833  yp1k01 = yp1k01 + h(i)*dpa01*12.*cgam10*xcc1
9834  yp1k1 = yp1k1 + h(i)*xcc1*(-12.*dpa02+2.*(phcrtk-phtz0)*dpa03)
9835  ! n=2
9836  yp1k02 = yp1k02 + h(i)*dpa01*12.*cgam10*xcc1*xcc1
9837  yp1k2 = yp1k2 + h(i)*xcc1*xcc1*(-12.*dpa02+2.*(phcrtk-phtz0)*dpa03)
9838  ! INTEGRALES DERIVES PB0(Z)
9839  dpb01 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**4)
9840  dpb02 = sqcttf*sin(phit1-pcrest)*gi*gak/((gi*gi-1.)**4)
9841  dpb02 = dpb02
9842  dpb03 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**3)
9843  ! n=1
9844  yp2k01 = yp2k01 + h(i)*dpb01*12.*cgam10*xcc1
9845  yp2k1 = yp2k1 + h(i)*xcc1*(-12.*dpb02-2.*(phcrtk-phtz0)*dpb03)
9846  ! n=2
9847  yp2k02 = yp2k02 + h(i)*dpb01*12.*cgam10*xcc1*xcc1
9848  yp2k2 = yp2k2 + h(i)*xcc1*xcc1*(-12.*dpb02-2.*(phcrtk-phtz0)*dpb03)
9849  end do
9850 200 continue
9851  ! in COS
9852  ! LONGITUDINAL INTEGRALS
9853  yh1k00 = yh1k00/2.*eqvl
9854  yh1k01 = yh1k01/2.*eqvl
9855  yh1k0 = yh1k0/2.*eqvl
9856  yh1k1 = yh1k1/2.*eqvl
9857  yp1k1 = yp1k1/2.*eqvl
9858  yp1k2 = yp1k2/2.*eqvl
9859  yp1k01 = yp1k01/2.*eqvl
9860  yp1k02 = yp1k02/2.*eqvl
9861  yh10 = yh10*eqvl/2.
9862  yh11 = yh11*eqvl/2.
9863  yp11 = yp11*eqvl/2.
9864  yp12 = yp12*eqvl/2.
9865  ! Transverse integrals
9866  ye1k0 = ye1k0/2.*eqvl
9867  ye1kc0 = ye1kc0/2.*eqvl
9868  ye1k1 = ye1k1/2.*eqvl
9869  ye1kc1 = ye1kc1/2.*eqvl
9870  ye1k2 = ye1k2/2.*eqvl
9871  ye1kc2 = ye1kc2/2.*eqvl
9872  ye10 = ye10*eqvl/2.
9873  ye11 = ye11*eqvl/2.
9874  ye12 = ye12*eqvl/2.
9875  ! in SIN
9876  ! LONGITUDINAL INTEGRALS
9877  yh2k00 = yh2k00/2.*eqvl
9878  yh2k01 = yh2k01/2.*eqvl
9879  yh2k0 = yh2k0/2.*eqvl
9880  yh2k1 = yh2k1/2.*eqvl
9881  yp2k1 = yp2k1/2.*eqvl
9882  yp2k2 = yp2k2/2.*eqvl
9883  yp2k01 = yp2k01/2.*eqvl
9884  yp2k02 = yp2k02/2.*eqvl
9885  yh20 = yh20*eqvl/2.
9886  yh21 = yh21*eqvl/2.
9887  yp21 = yp21*eqvl/2.
9888  yp22 = yp22*eqvl/2.
9889  ! TRANSVERSE INTEGRALS
9890  ye2k0 = ye2k0/2.*eqvl
9891  ye2kc0 = ye2kc0/2.*eqvl
9892  ye2k1 = ye2k1/2.*eqvl
9893  ye2kc1 = ye2kc1/2.*eqvl
9894  ye2k2 = ye2k2/2.*eqvl
9895  ye2kc2 = ye2kc2/2.*eqvl
9896  ye20 = ye20*eqvl/2.
9897  ye21 = ye21*eqvl/2.
9898  ye22 = ye22*eqvl/2.
9899  ! 100 CONTINUE
9900  return
9901  end subroutine xtypl1
9902  ! *******************************************************************
9903  ! SUBROUTINE chasel
9904  ! analysis of emittance by elimination of remote particles in the
9905  ! z-direction
9906  ! *******************************************************************
9907  subroutine chasel
9908  implicit real *8(a-h, o-z)
9909  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
9910  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
9911  common /fene/wdisp, wphas, wx, wy, rlim, ifw
9912  common /faisc/f(10, iptsz), imax, ngood
9913  common /qmoyen/qmoy
9914  common /consta/vl, pi, xmat, rpel, qst
9915  common /tapes/in, ifile, meta
9916  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
9917  logical chasit
9918  common /etchas/fractx, fracty, fractl
9919  common /etcom/cog(8), exten(17), fd(iptsz)
9920  common /pool/zl(iptsz), ipin(iptsz)
9921 
9922  if (fractl>=1.) return
9923  do i = 1, ngood
9924  ichas(i) = 1
9925  zl(i) = 0.
9926  ipin(i) = 1
9927  end do
9928  nl = int(float(ngood)*fractl)
9929  inz = 0
9930  imaxf = ngood
9931  inx = 0
9932  ! ellipsoid of concentration (phase-dispersion)
9933  tx2 = 0.
9934  txp2 = 0.
9935  txxp = 0.
9936  do i = 1, ngood
9937  tx2 = tx2 + f(6, i)*f(6, i)
9938  txp2 = txp2 + fd(i)*fd(i)
9939  txxp = txxp + f(6, i)*fd(i)
9940  end do
9941  tx2 = tx2/float(ngood)
9942  txp2 = txp2/float(ngood)
9943  txxp = txxp/float(ngood)
9944  delxxp = tx2*txp2 - txxp*txxp
9945  ikept = 0
9946  do i = 1, ngood
9947  theta = pi/2.
9948  if (fd(i)/=0.) theta = atan(f(6,i)/fd(i))
9949  rpart = f(6, i)*f(6, i) + fd(i)*fd(i)
9950  cos2 = cos(theta)*cos(theta)
9951  sin2 = sin(theta)*sin(theta)
9952  denom = tx2*cos2 + txp2*sin2 - 2.*txxp*cos(theta)*sin(theta)
9953  relpse = 2.5*delxxp/denom
9954  if (fractl>=.97) then
9955  relpse = 3.5*delxxp/denom
9956  else
9957  if (fractl>=.95) relpse = 3.*delxxp/denom
9958  end if
9959  if (rpart<=relpse) then
9960  ipin(i) = 0
9961  ikept = ikept + 1
9962  end if
9963  end do
9964  write (16, *) ' CHASEL:', fractl, ' % over: ', ngood - ikept, ' particles'
9965  do j = 1, ngood
9966  if (ipin(j)==1) then
9967  inz = inz + 1
9968  if (imaxf<=nl) go to 9990
9969  imaxx = 0
9970  tx = 0.
9971  txp = 0.
9972  txxp = 0.
9973  tx2 = 0.
9974  txp2 = 0.
9975  do i = 1, ngood
9976  if (ichas(i)==1) then
9977  tx = f(6, i) + tx
9978  txp = fd(i) + txp
9979  tx2 = tx2 + f(6, i)*f(6, i)
9980  txp2 = txp2 + fd(i)*fd(i)
9981  txxp = txxp + f(6, i)*fd(i)
9982  imaxx = imaxx + 1
9983  end if
9984  end do
9985  tx = tx/float(imaxx)
9986  txp = txp/float(imaxx)
9987  tx2 = tx2/float(imaxx)
9988  txp2 = txp2/float(imaxx)
9989  txxp = txxp/float(imaxx)
9990  xcg = tx
9991  zcg = txp
9992  ! betatron parameters
9993  xxl = tx2 - tx*tx
9994  zzl = txp2 - txp*txp
9995  xzl = txxp - tx*txp
9996  if (inz==1) go to 8880
9997  flcrit = 2.*fl2rms*log(2.*imaxx)
9998  if (zlma<flcrit) go to 7770
9999 8880 emil = sqrt(xxl*zzl-xzl*xzl)
10000  if (emil==0.) then
10001  al = 0.
10002  bl = 0.
10003  cl = 0.
10004  else
10005  bl = sqrt(xxl/emil)
10006  cl = 1./bl
10007  al = -xzl/emil
10008  end if
10009  tlx0 = tx
10010  tlz0 = txp
10011 7770 fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
10012  zlma = 0.
10013  do i = 1, ngood
10014  zl(i) = 0.
10015  if (ichas(i)==1) then
10016  psx = f(6, i) - tlx0
10017  psz = fd(i) - tlz0
10018  zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
10019  if (zlma<zl(i)) then
10020  zlma = zl(i)
10021  izlma = i
10022  end if
10023  end if
10024  end do
10025  ! particle is eliminated
10026  imaxf = 0
10027  if (zlma==0.) zlma = 1.e10
10028  do i = 1, ngood
10029  if (ichas(i)==1 .and. zl(i)<zlma) then
10030  imaxf = imaxf + 1
10031  else
10032  ichas(i) = 0
10033  end if
10034  end do
10035  end if
10036  end do
10037 9990 continue
10038  return
10039  end subroutine chasel
10040  ! *******************************************************************
10041  ! SUBROUTINE chasex
10042  ! analysis of emittance by elimination of remote particles in the
10043  ! x-direction
10044  ! *******************************************************************
10045  subroutine chasex
10046  implicit real *8(a-h, o-z)
10047  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10048  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10049  common /fene/wdisp, wphas, wx, wy, rlim, ifw
10050  common /faisc/f(10, iptsz), imax, ngood
10051  common /qmoyen/qmoy
10052  common /consta/vl, pi, xmat, rpel, qst
10053  common /tapes/in, ifile, meta
10054  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
10055  logical chasit
10056  common /etchas/fractx, fracty, fractl
10057  common /pool/zl(iptsz), ipin(iptsz)
10058 
10059  if (fractx>=1.) return
10060  do i = 1, ngood
10061  ichas(i) = 1
10062  zl(i) = 0.
10063  ipin(i) = 1
10064  end do
10065  nl = int(float(ngood)*fractx)
10066  inz = 0
10067  imaxf = ngood
10068  inx = 0
10069  ! ellipsoid of concentration (x-xp)
10070  tx2 = 0.
10071  txp2 = 0.
10072  txxp = 0.
10073  do i = 1, ngood
10074  f2 = f(2, i)*1.e-02
10075  f3 = f(3, i)*1.e-03
10076  tx2 = tx2 + f2*f2
10077  txp2 = txp2 + f3*f3
10078  txxp = txxp + f2*f3
10079  end do
10080  tx2 = tx2/float(ngood)
10081  txp2 = txp2/float(ngood)
10082  txxp = txxp/float(ngood)
10083  delxxp = tx2*txp2 - txxp*txxp
10084  ikept = 0
10085  do i = 1, ngood
10086  theta = pi/2.
10087  f2 = f(2, i)*1.e-02
10088  f3 = f(3, i)*1.e-03
10089  if (f3/=0.) theta = atan(f2/f3)
10090  rpart = f2*f2 + f3*f3
10091  cos2 = cos(theta)*cos(theta)
10092  sin2 = sin(theta)*sin(theta)
10093  denom = tx2*cos2 + txp2*sin2 - 2.*txxp*cos(theta)*sin(theta)
10094  relpse = 2.5*delxxp/denom
10095  if (fractx>=.97) then
10096  relpse = 3.5*delxxp/denom
10097  else
10098  if (fractx>=.95) relpse = 3.*delxxp/denom
10099  end if
10100  if (rpart<=relpse) then
10101  ipin(i) = 0
10102  ikept = ikept + 1
10103  end if
10104  end do
10105  write (16, *) ' CHASEX:', fractx, ' % over: ', ngood - ikept, ' particles'
10106  do j = 1, ngood
10107  if (ipin(j)==1) then
10108  inz = inz + 1
10109  if (imaxf<=nl) go to 9990
10110  imaxx = 0
10111  tx = 0.
10112  txp = 0.
10113  txxp = 0.
10114  tx2 = 0.
10115  txp2 = 0.
10116  do i = 1, ngood
10117  if (ichas(i)==1) then
10118  tx = f(2, i) + tx
10119  txp = f(3, i) + txp
10120  tx2 = tx2 + f(2, i)*f(2, i)
10121  txp2 = txp2 + f(3, i)*f(3, i)
10122  txxp = txxp + f(2, i)*f(3, i)
10123  imaxx = imaxx + 1
10124  end if
10125  end do
10126  tx = tx/float(imaxx)
10127  txp = txp/float(imaxx)
10128  tx2 = tx2/float(imaxx)
10129  txp2 = txp2/float(imaxx)
10130  txxp = txxp/float(imaxx)
10131  xcg = tx
10132  zcg = txp
10133  ! betatron parameters
10134  xxl = tx2 - tx*tx
10135  zzl = txp2 - txp*txp
10136  xzl = txxp - tx*txp
10137  if (inz==1) go to 8880
10138  flcrit = 2.*fl2rms*log(2.*imaxx)
10139  if (zlma<flcrit) go to 7770
10140 8880 emil = sqrt(xxl*zzl-xzl*xzl)
10141  if (emil==0.) then
10142  al = 0.
10143  bl = 0.
10144  cl = 0.
10145  else
10146  bl = sqrt(xxl/emil)
10147  cl = 1./bl
10148  al = -xzl/emil
10149  end if
10150  tlx0 = tx
10151  tlz0 = txp
10152 7770 fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
10153  zlma = 0.
10154  do i = 1, ngood
10155  zl(i) = 0.
10156  if (ichas(i)==1) then
10157  psx = f(2, i) - tlx0
10158  psz = f(3, i) - tlz0
10159  zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
10160  if (zlma<zl(i)) then
10161  zlma = zl(i)
10162  izlma = i
10163  end if
10164  end if
10165  end do
10166  ! particle is eliminated
10167  imaxf = 0
10168  if (zlma==0.) zlma = 1.e10
10169  do i = 1, ngood
10170  if (ichas(i)==1 .and. zl(i)<zlma) then
10171  imaxf = imaxf + 1
10172  else
10173  ichas(i) = 0
10174  end if
10175  end do
10176  end if
10177  end do
10178 9990 continue
10179  return
10180  end subroutine chasex
10181  ! *******************************************************************
10182  ! SUBROUTINE chase
10183  ! analysis of emittance by elimination of remote particles
10184  ! read the parameters and print them out
10185  ! *******************************************************************
10186  subroutine chase
10187  implicit real *8(a-h, o-z)
10188  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10189  common /tapes/in, ifile, meta
10190  common /etchas/fractx, fracty, fractl
10191  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
10192  logical chasit
10193 
10194  read (in, *) fractx, fracty, fractl
10195  write (16, 1) fractx*100., fracty*100., fractl*100.
10196 1 format (' ARE KEPT IN THE BUNCH ', /, ' (x,xp) : ', f7.3, ' %', /, ' (y,yp) : ', f7.3, ' % ', &
10197  /, ' (w,phase):', f7.3, ' %')
10198 
10199  chasit = .false.
10200  if (fractx<1.) chasit = .true.
10201  if (fracty<1.) chasit = .true.
10202  if (fractl<1.) chasit = .true.
10203  return
10204  end subroutine chase
10205  ! *******************************************************************
10206  ! SUBROUTINE chasey
10207  ! analysis of emittance by elimination of remote particles in the
10208  ! y-direction
10209  ! *******************************************************************
10210  subroutine chasey
10211  implicit real *8(a-h, o-z)
10212  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10213  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10214  common /fene/wdisp, wphas, wx, wy, rlim, ifw
10215  common /faisc/f(10, iptsz), imax, ngood
10216  common /qmoyen/qmoy
10217  common /consta/vl, pi, xmat, rpel, qst
10218  common /tapes/in, ifile, meta
10219  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
10220  logical chasit
10221  common /etchas/fractx, fracty, fractl
10222  common /pool/zl(iptsz), ipin(iptsz)
10223 
10224  if (fracty>=1.) return
10225  do i = 1, ngood
10226  ichas(i) = 1
10227  zl(i) = 0.
10228  ipin(i) = 1
10229  end do
10230  ! ellipsoid of concentration (y-yp)
10231  ty2 = 0.
10232  typ2 = 0.
10233  tyyp = 0.
10234  do i = 1, ngood
10235  f4 = f(4, i)*1.e-02
10236  f5 = f(5, i)*1.e-03
10237  ty2 = ty2 + f4*f4
10238  typ2 = typ2 + f5*f5
10239  tyyp = tyyp + f4*f5
10240  end do
10241  ty2 = ty2/float(ngood)
10242  typ2 = typ2/float(ngood)
10243  tyyp = tyyp/float(ngood)
10244  delyyp = ty2*typ2 - tyyp*tyyp
10245  ikept = 0
10246  do i = 1, ngood
10247  f4 = f(4, i)*1.e-02
10248  f5 = f(5, i)*1.e-03
10249  theta = pi/2.
10250  if (f5/=0.) theta = atan(f4/f5)
10251  rpart = f4*f4 + f5*f5
10252  cos2 = cos(theta)*cos(theta)
10253  sin2 = sin(theta)*sin(theta)
10254  denom = ty2*cos2 + typ2*sin2 - 2.*tyyp*cos(theta)*sin(theta)
10255  relpse = 2.5*delyyp/denom
10256  if (fracty>=.97) then
10257  relpse = 3.5*delyyp/denom
10258  else
10259  if (fracty>=.95) relpse = 3.*delyyp/denom
10260  end if
10261  if (rpart<=relpse) then
10262  ipin(i) = 0
10263  ikept = ikept + 1
10264  end if
10265  end do
10266  write (16, *) ' CHASEY:', fracty, ' % over: ', ngood - ikept, ' particles'
10267  imaxf = ngood
10268  nl = int(float(ngood)*fracty)
10269  inz = 0
10270  do j = 1, ngood
10271  if (ipin(j)==1) then
10272  inz = inz + 1
10273  if (imaxf<=nl) go to 9990
10274  imaxx = 0
10275  ty = 0.
10276  typ = 0.
10277  tyyp = 0.
10278  ty2 = 0.
10279  typ2 = 0.
10280  do i = 1, ngood
10281  if (ichas(i)==1) then
10282  ty = f(4, i) + ty
10283  typ = f(5, i) + typ
10284  ty2 = ty2 + f(4, i)*f(4, i)
10285  typ2 = typ2 + f(5, i)*f(5, i)
10286  tyyp = tyyp + f(4, i)*f(5, i)
10287  imaxx = imaxx + 1
10288  end if
10289  end do
10290  ty = ty/float(imaxx)
10291  typ = typ/float(imaxx)
10292  ty2 = ty2/float(imaxx)
10293  typ2 = typ2/float(imaxx)
10294  tyyp = tyyp/float(imaxx)
10295  xcg = ty
10296  zcg = typ
10297  ! betatron parameters
10298  xxl = ty2 - ty*ty
10299  zzl = typ2 - typ*typ
10300  xzl = tyyp - ty*typ
10301  if (inz==1) go to 8880
10302  flcrit = 2.*fl2rms*log(2.*imaxx)
10303  if (zlma<flcrit) go to 7770
10304 8880 emil = sqrt(xxl*zzl-xzl*xzl)
10305  if (emil==0.) then
10306  al = 0.
10307  bl = 0.
10308  cl = 0.
10309  else
10310  bl = sqrt(xxl/emil)
10311  cl = 1./bl
10312  al = -xzl/emil
10313  end if
10314  tlx0 = ty
10315  tlz0 = typ
10316 7770 fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
10317  zlma = 0.
10318  do i = 1, ngood
10319  zl(i) = 0.
10320  if (ichas(i)==1) then
10321  psx = f(4, i) - tlx0
10322  psz = f(5, i) - tlz0
10323  zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
10324  if (zlma<zl(i)) then
10325  zlma = zl(i)
10326  izlma = i
10327  end if
10328  end if
10329  end do
10330  ! particle is eliminated
10331  imaxf = 0
10332  if (zlma==0.) zlma = 1.e10
10333  do i = 1, ngood
10334  if (ichas(i)==1 .and. zl(i)<zlma) then
10335  imaxf = imaxf + 1
10336  else
10337  ichas(i) = 0
10338  end if
10339  end do
10340  end if
10341  end do
10342 9990 continue
10343  return
10344  end subroutine chasey
10345  ! *******************************************************************
10346  ! SUBROUTINE corre(n,nall)
10347  ! correction over the beam generated by MONTE
10348  ! *******************************************************************
10349  subroutine corre(n, nall)
10350  implicit real *8(a-h, o-z)
10351  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10352  common /com4/cord(iptsz, 6)
10353  dimension a(6, 6), b(6, 6), c(6, 6), d(6), e(6), f(6), g(6)
10354 
10355  do i = 1, 6
10356  d(i) = 0.0
10357  e(i) = 0.0
10358  f(i) = 0.0
10359  g(i) = 0.0
10360  do j = 1, 6
10361  a(i, j) = 0.0
10362  b(i, j) = 0.0
10363  c(i, j) = 0.0
10364  end do
10365  end do
10366  do j = 1, 6
10367  do i = 1, n
10368  d(j) = d(j) + cord(i, j)
10369  end do
10370  d(j) = d(j)/n
10371  end do
10372  do j = 1, 6
10373  do i = 1, nall
10374  cord(i, j) = cord(i, j) - d(j)
10375  end do
10376  end do
10377  do j = 1, 6
10378  do k = 1, j
10379  do i = 1, n
10380  a(j, k) = a(j, k) + cord(i, j)*cord(i, k)
10381  end do
10382  a(j, k) = a(j, k)/n
10383  end do
10384  end do
10385  ! WE MAKE MATRIX A=B*BT WHERE B,BT ARE TRIANGULAR
10386  do i = 1, 6
10387  do j = 1, i
10388  h = a(i, j)
10389  j1 = j - 1
10390  if (j==1) go to 8
10391  do k = 1, j1
10392  h = h - a(i, k)*a(j, k)
10393  end do
10394 8 if (i==j) go to 10
10395  a(i, j) = h/a(j, j)
10396  go to 7
10397 10 a(i, j) = sqrt(h)
10398 7 b(i, j) = a(i, j)
10399  end do
10400  end do
10401  ! WE INVERT B TO GIVE AN UPDATED B
10402  e(1) = 1.0/b(1, 1)
10403  do i = 2, 6
10404  e(i) = 1.0/b(i, i)
10405  j1 = i - 1
10406  do jj = 1, j1
10407  j = i - jj
10408  j3 = j + 1
10409  s = 0.0
10410  if (jj==1) go to 13
10411  do k = j3, j1
10412  s = s - b(k, i)*b(k, j)
10413  end do
10414 13 b(j, i) = (s-b(i,j)*e(i))/b(j, j)
10415  end do
10416  end do
10417  do i = 1, 6
10418  b(i, i) = e(i)
10419  end do
10420  do i = 1, 6
10421  do j = 1, i
10422  dum = b(i, j)
10423  b(i, j) = b(j, i)
10424  b(j, i) = dum
10425  end do
10426  end do
10427  ! WE CONVERT CORD(**) SO THAT ITS SIGMA MATRIX IS UNITY
10428  do i = 1, nall
10429  do k = 1, 6
10430  f(k) = 0.0
10431  do j = 1, k
10432  f(k) = f(k) + b(k, j)*cord(i, j)
10433  end do
10434  end do
10435  do k = 1, 6
10436  cord(i, k) = f(k)
10437  end do
10438  end do
10439  ! WE TEST THE MEANS AND SIGMA MATRIX
10440  do j = 1, 6
10441  do i = 1, n
10442  g(j) = g(j) + cord(i, j)
10443  end do
10444  g(j) = g(j)/n
10445  end do
10446  do j = 1, 6
10447  do i = 1, n
10448  cord(i, j) = cord(i, j) - g(j)
10449  end do
10450  end do
10451  do j = 1, 6
10452  do k = 1, 6
10453  do i = 1, n
10454  c(j, k) = c(j, k) + cord(i, j)*cord(i, k)
10455  end do
10456  c(j, k) = c(j, k)/n
10457  end do
10458  end do
10459  return
10460  end subroutine corre
10461  ! *******************************************************************
10462  ! SUBROUTINE pintim
10463  ! Shifts particle coordinates to a single point in time. Uses a
10464  ! linear shift Divide by 100 to convert from cm to meters
10465  ! called by SCHEFF or SCHERM
10466  ! *******************************************************************
10467  subroutine pintim
10468  implicit real *8(a-h, o-z)
10469  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10470  common /faisc/f(10, iptsz), imax, ngood
10471  common /qmoyen/qmoy
10472  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
10473  common /consta/vl, pi, xmat, rpel, qst
10474  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
10475  common /azlist/icont, iprin
10476 
10477  grmoy = 0.
10478  trmoy = 0.
10479  xbax = 0.
10480  do i = 1, ngood
10481  grmoy = grmoy + f(7, i)/xmat
10482  trmoy = trmoy + f(6, i)
10483  xbax = xbax + f(2, i)
10484  end do
10485  trmoy = trmoy/float(ngood)
10486  grmoy = grmoy/float(ngood)
10487  brmoy = sqrt(1.-1./(grmoy*grmoy))
10488  xbax = xbax/float(ngood)
10489  apl = 0.
10490  ! Isochronism correction (bending magnet) only with SCHERM
10491  ! does not work with with SCHEFF (iscsp=3)
10492  if (iscsp==2) then
10493  xb2x = 0.
10494  xb2z = 0.
10495  xbxz = 0.
10496  do np = 1, ngood
10497  gpai = f(7, np)/xmat
10498  bpai = sqrt(1.-1./(gpai*gpai))
10499  zc(np) = (trmoy-f(6,np))*bpai*vl/100.
10500  xc(np) = (f(2,np)-xbax)/100.
10501  xb2z = xb2z + zc(np)*zc(np)
10502  xb2x = xb2x + xc(np)*xc(np)
10503  xbxz = xbxz + zc(np)*xc(np)
10504  end do
10505  xb2z = xb2z/float(ngood)
10506  xb2x = xb2x/float(ngood)
10507  xbxz = xbxz/float(ngood)
10508  apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
10509  write (16, *) 'slope of the bunch in plane(Oz,Ox):', apl, ' radian'
10510  end if
10511  do np = 1, ngood
10512  gpai = f(7, np)/xmat
10513  bpai = sqrt(1.-1./(gpai*gpai))
10514  ! iscsp = 3 Lorentz transformation (only with scheff)
10515  ! omment if(iscsp.eq.3) znp=(trmoy-f(6,np))*bpai*vl*grmoy
10516  ! omment if(iscsp.eq.2) znp=(trmoy-f(6,np))*bpai*vl
10517  znp = (trmoy-f(6,np))*bpai*vl
10518  xnp = f(2, np)
10519  zc(np) = znp*cos(apl) + xnp*sin(apl)
10520  xnp = xnp*cos(apl) - znp*sin(apl)
10521  ! convert from mrad to rad
10522  f3 = f(3, np)*1.e-03
10523  f5 = f(5, np)*1.e-03
10524  ! convert from cm to m
10525  xc(np) = (xnp+zc(np)*f3)/100.
10526  yc(np) = (f(4,np)+zc(np)*f5)/100.
10527  zc(np) = zc(np)/100.
10528  end do
10529  xbar = 0.
10530  ybar = 0.
10531  zbar = 0.
10532  do np = 1, ngood
10533  ! evaluate xbar , ybar , zbar
10534  xbar = xbar + xc(np)
10535  ybar = ybar + yc(np)
10536  zbar = zbar + zc(np)
10537  end do
10538  xbar = xbar/float(ngood)
10539  ybar = ybar/float(ngood)
10540  zbar = zbar/float(ngood)
10541  ! Translate distribution by center of mass coordinates to shift
10542  ! coordinate origin to (0,0,0)
10543  do np = 1, ngood
10544  xc(np) = xc(np) - xbar
10545  yc(np) = yc(np) - ybar
10546  zc(np) = zc(np) - zbar
10547  end do
10548  return
10549  end subroutine pintim
10550  ! *******************************************************************
10551  ! SUBROUTINE schermi1
10552  ! Called by SCHERMI when the bunch can be represented
10553  ! by a simple ellipse in the longitudinal direction
10554  ! *******************************************************************
10555  subroutine schermi1
10556  implicit real *8(a-h, o-z)
10557  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10558  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10559  common /hermt/afxt(22), afyt(22), afzt(22)
10560  common /hermd/afxm(20), afym(20), afzm(20)
10561  common /hermr/afxr(20), afyr(20), afzr(20)
10562  common /sizt/xrms, yrms, zrms
10563  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
10564  common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
10565  common /intgrt/ex, ey, ez
10566  common /degherm/nmaz, nmazr, nmaxy
10567  common /cdek/dwp(iptsz)
10568  common /consta/vl, pi, xmat, rpel, qst
10569  common /faisc/f(10, iptsz), imax, ngood
10570  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
10571  common /npart/imaxr
10572  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
10573  common /twcst/epsilon
10574  common /beamsa/fs(7, iptsz)
10575  common /dcspa/iesp
10576  common /cmpte/iell
10577  common /cgrms/xsum, ysum, zsum
10578  common /compt/nrres, nrtre, nrbunc, nrdbun
10579  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
10580  common /posc/xpsc
10581  logical ichaes, iesp
10582  dimension afx(20), afy(20)
10583 
10584  if (beamc==0. .or. scdist==0.) return
10585  iell = iell + 1
10586  imaxf = ngood
10587  wavel = 2.*pi*vl/fh
10588  xmass = xmat*1.78267581e-30
10589  nmaxy = 5
10590  dxp = 0.
10591  dyp = 0.
10592  dw = 0.
10593  dz = scdist/100.
10594  dz1 = dz
10595  if (ngood==0) then
10596  write (16, *) ' all the particles are lost '
10597  stop
10598  end if
10599  ! xi in Amps, beamc in mA
10600  ! epsilon =(coul*coul)/nt*(m*m)
10601  epsilon = 8.854189586e-12
10602  c1 = 1./(3.*pi*sqrt(5.))
10603  cl = vl/100.
10604  ! charge per macro particle
10605  ! omment const1=c1*xi*xi*wavel*wavel/(10000.*imaxf*xmass*
10606  ! * epsilon*cl*cl*cl*cl)
10607  const3 = 1.e-06
10608  const2 = 1.e-06/xmat
10609  ! calculate rms beam size for beam in one point in time
10610  call sizrms(0, xrms, yrms, zrms, zz)
10611  ! 6875 format(2x,e12.5,2x,e12.5,2x,e12.5)
10612  xrmsp = xrms
10613  yrmsp = yrms
10614  zrmsp = zrms
10615  call sizcor(ect, xrms, yrms, zrms, 0)
10616  xrmsc = xrms
10617  yrmsc = yrms
10618  zrmsc = zrms
10619  xrms1 = xrmsp
10620  yrms1 = yrmsp
10621  zrms1 = zrmsp
10622  xrms = xrmsp
10623  yrms = yrmsp
10624  zrms = zrmsp
10625  xcgd = xsum
10626  ycgd = ysum
10627  zcgd = zsum
10628  do i = 1, ngood
10629  zcp(i) = zc(i)
10630  xcp(i) = xc(i)
10631  ycp(i) = yc(i)
10632  end do
10633  ! limits in z-direction
10634  zmat = 0.
10635  zmit = 1000.
10636  do i = 1, ngood
10637  if (zcp(i)>=zmat) zmat = zcp(i)
10638  if (zcp(i)<zmit) zmit = zcp(i)
10639  end do
10640  zmat = zmat/zrms
10641  zmit = zmit/zrms
10642  ! extends zmat
10643  zmat = zmat + zmat*.50
10644  zmit = zmit + zmit*.50
10645  if (zmat>ect) zmat = ect
10646  if (abs(zmit)>ect) zmit = -ect
10647  ! Hermite coefficients in x and y-direction
10648  nmaz = 0
10649  ! 6876 format(2x,i3,2x,i3)
10650  do k = 1, 20
10651  afzt(k) = 0.
10652  afxt(k) = 0.
10653  afyt(k) = 0.
10654  afzm(k) = 0.
10655  afxm(k) = 0.
10656  afym(k) = 0.
10657  end do
10658  do k = 1, nmaxy
10659  kap = k - 1
10660  do j = 1, ngood
10661  xcoup = abs(xcp(j)/xrms)
10662  ycoup = abs(ycp(j)/yrms)
10663  zcoup = abs(zcp(j)/zrms)
10664  if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
10665  xc(j) = xcp(j)/xrmsc
10666  yc(j) = ycp(j)/yrmsc
10667  zc(j) = zcp(j)/zrmsc
10668  afxm(k) = afxm(k) + herm(2*kap, xc(j))
10669  afym(k) = afym(k) + herm(2*kap, yc(j))
10670  afzm(k) = afzm(k) + herm(2*kap, zc(j))
10671  end if
10672  end do
10673  afxm(k) = afxm(k)/(fact(2*kap)*sqrt(2.*pi))
10674  afym(k) = afym(k)/(fact(2*kap)*sqrt(2.*pi))
10675  afzm(k) = afzm(k)/(fact(2*kap)*sqrt(2.*pi))
10676  end do
10677  nmaz = 10
10678  ! Hermite coefficients in z-direction
10679  zcdg = 0.
10680  imaxx = 0
10681  do j = 1, ngood
10682  xcoup = abs(xcp(j)/xrms)
10683  ycoup = abs(ycp(j)/yrms)
10684  zcoup = abs(zcp(j)/zrms)
10685  if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
10686  zcdg = zcdg + zcp(j)
10687  imaxx = imaxx + 1
10688  end if
10689  end do
10690  zcdg = zcdg/float(imaxx)
10691  zsqsum = 0.
10692  zcub = 0.
10693  zcub1 = 0.
10694  do j = 1, ngood
10695  xcoup = abs(xcp(j)/xrms)
10696  ycoup = abs(ycp(j)/yrms)
10697  zcoup = abs(zcp(j)/zrms)
10698  if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
10699  zc(j) = zcp(j) - zcdg
10700  zsqsum = zsqsum + zc(j)*zc(j)
10701  zcub = zcub + zc(j)*zc(j)*zc(j)
10702  zcub1 = zcub1 + zc(j)
10703  end if
10704  end do
10705  zrmsz = zsqsum/float(imaxx)
10706  zrmsz = sqrt(zrmsz)
10707  zcub3 = zcub
10708  zcub = zcub/(zrmsz*zrmsz*zrmsz) - 3.*zcub1/zrmsz
10709  zcub = zcub/(6.*sqrt(2.*pi))
10710  do k = 1, nmaz
10711  afzt(k) = 0.
10712  afx(k) = 0.
10713  afy(k) = 0.
10714  kap = k - 1
10715  do j = 1, ngood
10716  xcoup = abs(xcp(j)/xrms)
10717  ycoup = abs(ycp(j)/yrms)
10718  zcoup = abs(zcp(j)/zrms)
10719  if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
10720  zc(j) = zcp(j)/zrmsc
10721  xc(j) = xcp(j)/xrmsc
10722  yc(j) = ycp(j)/yrmsc
10723  afzt(k) = afzt(k) + herm(kap, zc(j))
10724  afx(k) = afx(k) + herm(kap, xc(j))
10725  afy(k) = afy(k) + herm(kap, yc(j))
10726  end if
10727  end do
10728  afzt(k) = afzt(k)/(fact(kap)*sqrt(2.*pi))
10729  afx(k) = afx(k)/(fact(kap)*sqrt(2.*pi))
10730  afy(k) = afy(k)/(fact(kap)*sqrt(2.*pi))
10731  end do
10732  ! Do Hermite integration to determine Ex,Ey,Ez for each macro particle
10733  ! and apply space charge kick. Field components are passed through the
10734  ! common INTGRT in units Newton/Coulomb
10735  do i = 1, ngood
10736  ! reprise coordonnees spaciales pour calcul des champs
10737  xc(i) = xcp(i)
10738  yc(i) = ycp(i)
10739  zc(i) = zcp(i)
10740  call intga(i, 0)
10741  ext = ex
10742  eyt = ey
10743  ezt = ez
10744  ! calculate kick in x',y' and z' (energy)
10745  ! calculate kick in x',y' and z' (energy)
10746  ! isochronism correction
10747  eztp = ezt*cos(apl) - ext*sin(apl)
10748  extp = ezt*sin(apl) + ext*cos(apl)
10749  ezt = eztp
10750  ext = extp
10751  gsc = f(7, i)/xmat
10752  bsc = sqrt(1.-1./(gsc*gsc))
10753  ! * valero
10754  dxp = const2*ext*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
10755  dyp = const2*eyt*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
10756  dw = const3*ezt*dz*abs(f(9,i))/gsc
10757  ! *
10758  if (.not. iesp) then
10759  ! load the entrance beam in cavities or gaps
10760  do js = 1, 7
10761  f(js, i) = fs(js, i)
10762  end do
10763  f(3, i) = f(3, i) + dxp*1000.
10764  f(5, i) = f(5, i) + dyp*1000.
10765  f(2, i) = f(2, i) - dz1*dxp*100.*xpsc
10766  f(4, i) = f(4, i) - dz1*dyp*100.*xpsc
10767  dwp(i) = dw
10768  else
10769  f(3, i) = f(3, i) + dxp*1000.
10770  f(5, i) = f(5, i) + dyp*1000.
10771  f(7, i) = f(7, i) + dw
10772  end if
10773  end do
10774  return
10775  end subroutine schermi1
10776  ! *******************************************************************
10777  ! SUBROUTINE schermi
10778  ! SCHERM space charge method
10779  ! See NIM A 309(1996) 21-40
10780  ! *******************************************************************
10781  subroutine schermi
10782  implicit real *8(a-h, o-z)
10783  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
10784  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
10785  common /hermt/afxt(22), afyt(22), afzt(22)
10786  common /hermd/afxm(20), afym(20), afzm(20)
10787  common /hermr/afxr(20), afyr(20), afzr(20)
10788  common /hermrr/afxrr(20), afyrr(20), afzrr(20)
10789  common /sizr/xrms3, yrms3, zrms3, zcgr3
10790  common /sizt/xrms, yrms, zrms
10791  common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
10792  common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
10793  common /intgrt/ex, ey, ez
10794  common /degherm/nmaz, nmazr, nmaxy
10795  common /cdek/dwp(iptsz)
10796  common /consta/vl, pi, xmat, rpel, qst
10797  common /faisc/f(10, iptsz), imax, ngood
10798  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
10799  common /npart/imaxr
10800  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
10801  common /twcst/epsilon
10802  common /beamsa/fs(7, iptsz)
10803  common /dcspa/iesp
10804  common /cmpte/iell
10805  common /champ/fxrms(10, 15), fyrms(10, 15), fzrms(10, 15), nchamp(10), nccham(10), nchpas, jcham, itye
10806  common /compt/nrres, nrtre, nrbunc, nrdbun
10807  common /posc/xpsc
10808  logical ichaes, iesp
10809  ! *************************************************
10810  ! nquad : number of quad in the transport line
10811  common /chqua/icqd, nquad
10812  logical icqd
10813  ! *************************************************
10814  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
10815 
10816  if (beamc==0. .or. scdist==0.) return
10817  ! dummy: in order to have the same entry as HERSC and SCHEFF
10818  ! Initialize some constants and variables c wavel in cm
10819  ect = 4.
10820  call shuffle
10821  call pintim
10822  iell = iell + 1
10823  imaxf = ngood
10824  wavel = 2.*pi*vl/fh
10825  xmass = xmat*1.78267581e-30
10826  nmaz = 14
10827  nmazr = 8
10828  nmaxy = 4
10829  dxp = 0.
10830  dyp = 0.
10831  dw = 0.
10832  dz = scdist/100.
10833  dz1 = dz
10834  zsot1 = 0.
10835  if (ngood==0) then
10836  write (16, *) ' all the particles are lost '
10837  stop
10838  end if
10839  write (16, *) ' call SCHERM N: ', iell
10840  ! xi in Amps, beamc in mA
10841  ! epsilon =(coul*coul)/nt*(m*m)
10842  epsilon = 8.854189586e-12
10843  c1 = 1./(3.*pi*sqrt(5.))
10844  cl = vl/100.
10845  ! charge per macro particle
10846  const3 = 1.e-06
10847  const2 = 1.e-06/xmat
10848  ! normalized emittances(normalized) in m.radian
10849  ! calculate rms beam size for beam in one point in time
10850  call sizrms(0, xrms, yrms, zrms, zz)
10851  xrmsp = xrms
10852  yrmsp = yrms
10853  zrmsp = zrms
10854  call sizcor(ect, xrms, yrms, zrms, 0)
10855  write (16, *) ' bunch RMS(m): ', xrms, yrms, zrms
10856  ! 6875 format(2x,e12.5,2x,e12.5,2x,e12.5)
10857  xrmsc = xrms
10858  yrmsc = yrms
10859  zrmsc = zrms
10860  xrms = xrmsp
10861  yrms = yrmsp
10862  zrms = zrmsp
10863  ! Total bunch charge densities in x,y,z
10864  ! calculation of Hermite coefficients
10865  do i = 1, ngood
10866  zcp(i) = zc(i)
10867  xcp(i) = xc(i)
10868  ycp(i) = yc(i)
10869  end do
10870  ! limits in z-direction
10871  zmat = 0.
10872  zmit = 1000.
10873  do i = 1, ngood
10874  if (zcp(i)>=zmat) zmat = zcp(i)
10875  if (zcp(i)<zmit) zmit = zcp(i)
10876  end do
10877  zmat = zmat/zrms
10878  zmit = zmit/zrms
10879  ! extend zmat
10880  zmat = zmat + zmat*.50
10881  zmit = zmit + zmit*.50
10882  ! (xmat,ymat,zmat) >0
10883  if (zmat>ect) zmat = ect
10884  if (abs(zmit)>ect) zmat = -ect
10885  ! Hermite coefficients
10886  do k = 1, nmaxy
10887  afxt(k) = 0.
10888  afyt(k) = 0.
10889  kap = k - 1
10890  do j = 1, ngood
10891  xcoup = abs(xcp(j)/xrms)
10892  ycoup = abs(ycp(j)/yrms)
10893  zcoup = abs(zcp(j)/zrms)
10894  if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
10895  xc(j) = xcp(j)/xrmsc
10896  yc(j) = ycp(j)/yrmsc
10897  afxt(k) = afxt(k) + herm(2*kap, xc(j))
10898  afyt(k) = afyt(k) + herm(2*kap, yc(j))
10899  end if
10900  end do
10901  afxt(k) = afxt(k)/(fact(2*kap)*sqrt(2.*pi))
10902  afyt(k) = afyt(k)/(fact(2*kap)*sqrt(2.*pi))
10903  end do
10904  ! 6876 format(2x,i5,3x,e12.5,3x,e12.5)
10905  do k = 1, nmaz
10906  afzt(k) = 0.
10907  kap = k - 1
10908  do j = 1, ngood
10909  xcoup = abs(xcp(j)/xrms)
10910  ycoup = abs(ycp(j)/yrms)
10911  zcoup = abs(zcp(j)/zrms)
10912  if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
10913  zc(j) = zcp(j)/zrms
10914  afzt(k) = afzt(k) + herm(kap, zc(j))
10915  end if
10916  end do
10917  afzt(k) = afzt(k)/(fact(kap)*sqrt(2.*pi))
10918  end do
10919  ! 6877 format(3x,e12.5)
10920  ! Seek for surface of the bunch
10921  szbt = snzt(zmit, zmat)
10922  ! Seek for the vertex of the distribution n(z)
10923  ! between 0 and zmat/2
10924  zf = zmat/2.
10925  zi = 0.
10926  call rchsom(zi, zf, nmaz)
10927  zsot = (zi+zf)/2.
10928  ! 9999 CONTINUE
10929  zcgd = zsot*zrms
10930  ! Main ellipsoid (in the right of the vertex)
10931  imaxd = 1
10932  do i = 1, ngood
10933  if (zcp(i)>=zcgd) then
10934  xc(imaxd) = xcp(i)
10935  yc(imaxd) = ycp(i)
10936  zc(imaxd) = zcp(i)
10937  imaxd = imaxd + 1
10938  end if
10939  end do
10940  imaxd = imaxd - 1
10941  imaxr = ngood - 2*imaxd
10942  if (imaxr<0) then
10943  ! if imaxr<0 => use one ellips only, rather than 2
10944  pcent1 = float(2*imaxd)/float(ngood)
10945  pcent2 = float(imaxr)/float(ngood)
10946  if (icqd) nquad = nquad - 1
10947  iell = iell - 1
10948  write (16, *) ' one ellipsoid in z-direction '
10949  call pintim
10950  call schermi1
10951  return
10952  end if
10953  if (25*imaxr<imaxf .or. imaxr<=30) then
10954  pcent1 = float(2*imaxd)/float(ngood)
10955  pcent2 = float(imaxr)/float(ngood)
10956  iell = iell - 1
10957  if (icqd) nquad = nquad - 1
10958  ! if imaxr<.04*imaxf => use one ellips only, rather than 2
10959  write (16, *) 'one ellipsoid in z-direction '
10960  call pintim
10961  call schermi1
10962  if (12*imaxr<ngood) write (16, *) 'one ellipsoid in z-direction '
10963  if (imaxr<=40) write (16, *) ' one ellipsoid in z-direction '
10964  return
10965  end if
10966  i1elli = 0
10967  ! C.O.G. of the principal ellipsoid (in cm)
10968  ! longitudinal RMS of the pricipal ellipsoid
10969  zrmss1 = sqrt(vaprz(zsot,zmat))
10970  zrms1 = zrmss1*zrms
10971  ! RMS in the transverse directions
10972  xrms1 = xrms
10973  yrms1 = yrms
10974  ! surface n(z)
10975  szbd = snzd(zsot, zmat)
10976  rsnz = szbd/szbt
10977  ! coefficients Hermite en x,y,z sur partie droite en z
10978  ! principal ellipsoid
10979  do k = 1, nmaxy
10980  kap = k - 1
10981  afxm(k) = afxt(k)*rsnz
10982  afym(k) = afyt(k)*rsnz
10983  afzm(k) = prinz(zsot, zmat, k, zrmss1)
10984  afzm(k) = 2.*afzm(k)/(fact(2*kap)*sqrt(2.*pi))
10985  end do
10986  ! limits in x,y,z of the principal ellipsoid
10987  do i = 1, imaxd
10988  xc(i) = xc(i)/xrms
10989  yc(i) = yc(i)/yrms
10990  zc(i) = zc(i)/zrms
10991  end do
10992  xmam = xc(1)
10993  ymam = yc(1)
10994  zmam = zc(1)
10995  do i = 1, imaxd
10996  if (xc(i)>=xmam) xmam = xc(i)
10997  if (yc(i)>=ymam) ymam = yc(i)
10998  if (zc(i)>=zmam) zmam = zc(i)
10999  end do
11000  if (abs(xmam)>=ect) xmam = ect
11001  if (abs(ymam)>=ect) ymam = ect
11002  if (abs(zmam)>=ect) zmam = ect
11003  xmim = xmam
11004  ymim = ymam
11005  zmim = zmam
11006  do i = 1, imaxd
11007  if (xc(i)<xmim) xmim = xc(i)
11008  if (yc(i)<ymim) ymim = yc(i)
11009  if (zc(i)<zmim) zmim = zc(i)
11010  end do
11011  if (abs(xmim)>=ect) xmim = -ect
11012  if (abs(ymim)>=ect) ymim = -ect
11013  if (abs(zmim)>=ect) zmim = -ect
11014  ! partition commune @ x,y,z
11015  xymam = ymam
11016  xymim = ymim
11017  if (xmam>=xymam) xymam = xmam
11018  if (zmam>=xymam) xymam = zmam
11019  if (xmim<xymim) xymim = xmim
11020  if (zmim<xymim) xymim = zmim
11021  ! symmetrisation de l'intervalle
11022  if (abs(xymim)>=xymam) then
11023  xymam = abs(xymim)
11024  else
11025  xymim = -xymam
11026  end if
11027  ! vertex of the second ellipsoid
11028  aa = zmit
11029  bb = 2.*zsot - zmat
11030  cc = zsot
11031  dd = zmat
11032  call rchsor(aa, bb, cc, dd, ee)
11033  ! second ellipsoid around ee
11034  ! sz2e : surface
11035  zrms2 = varia(bb, cc, dd, ee)
11036  zrms2 = sqrt(zrms2)
11037  zcgr = ee*zrms
11038  sz2e = codsy(bb, cc, dd, ee, 1)
11039  afzr(1) = sz2e/sqrt(2.*pi)
11040  stm12 = abs(afzt(1)-afzm(1)-afzr(1))
11041  rs2e = sz2e/szbt
11042  xrms2 = xrms
11043  yrms2 = yrms
11044  do k = 1, nmaxy
11045  kap = k - 1
11046  afxr(k) = afxt(k)*rs2e
11047  afyr(k) = afyt(k)*rs2e
11048  afzr(k) = codsy(bb, cc, dd, ee, k)
11049  afzr(k) = afzr(k)/(fact(2*kap)*sqrt(2.*pi))
11050  end do
11051  ! two ellipsoids:
11052  if (stm12*10<=afzr(1)) inint = 2
11053  if (stm12*10>afzr(1)) then
11054  ! 3 ellipsoids;the principal ellipsoid,the second ellipsoid is symmetrized
11055  ! the third ellipsoid is defined around the c. of g. of the residu
11056  ee1 = grz(aa, bb, cc, dd, ee)
11057  if (ee1>ee) then
11058  inint = 2
11059  go to 1968
11060  end if
11061  zrms3 = variz(bb, cc, dd, ee, ee1)
11062  zrms3 = sqrt(zrms3)
11063  xrms3 = xrms
11064  yrms3 = yrms
11065  zcgr3 = ee1*zrms
11066  ! C.O.G. of the second ellipsoid
11067  ! on suppose xcgr et ycgr nuls pour le residu
11068  xcgr = 0.
11069  ycgr = 0.
11070  sz3e = codif(bb, cc, dd, ee, ee1, 1)
11071  rs3e = sz3e/szbt
11072  ! correction complementaire
11073  srtot = sz3e/sqrt(2.*pi) + afzr(1) + afzm(1)
11074  srtot = srtot - afzt(1)
11075  ! HErMITE coefficients over the residual ellips
11076  do k = 1, nmaxy
11077  kap = k - 1
11078  afxrr(k) = afxt(k)*rs3e
11079  afyrr(k) = afyt(k)*rs3e
11080  afzrr(k) = codif(bb, cc, dd, ee, ee1, k)
11081  afzrr(k) = afzrr(k)/(fact(2*kap)*sqrt(2.*pi))
11082  if (k==1) then
11083  tzrr = afzrr(k) - srtot
11084  if (tzrr>=0. .and. abs(tzrr)>=(afzrr(k)/10.)) then
11085  afxrr(k) = afxrr(k) - srtot
11086  afyrr(k) = afyrr(k) - srtot
11087  afzrr(k) = afzrr(k) - srtot
11088  end if
11089  end if
11090  end do
11091  ! end of calculus of 2nd ellips
11092  inint = 3
11093  end if
11094  zrms3 = zrms3*zrms
11095 1968 continue
11096  zrms2 = zrms2*zrms
11097  ! surface of the ellipsoids in pourcent
11098  write (16, *) ' surface of the ellipsoids in % of the bunch:'
11099  if (inint==2) then
11100  pcent1 = afzm(1)/afzt(1)
11101  pcent2 = afzr(1)/afzt(1)
11102  write (16, 7777) iell, pcent1, pcent2
11103  end if
11104  if (inint==3) then
11105  pcent1 = afzm(1)/afzt(1)
11106  pcent2 = afzr(1)/afzt(1)
11107  pcent3 = afzrr(1)/afzt(1)
11108  write (16, 7778) iell, pcent1, pcent2, pcent3
11109  end if
11110 7777 format (2x, i4, 2x, f7.4, 2x, f7.4)
11111 7778 format (2x, i4, 2x, f7.4, 2x, f7.4, 2x, f7.4)
11112  ! Do Hermite integration to determine Ex,Ey,Ez for each macro particle
11113  ! and apply space charge kick. Field components are passed through the
11114  ! common INTGRT in units Newton/Coulomb
11115  ! gsct introduit pour calcul specifique impulsion
11116  gsct = 0.
11117  igsct = 0
11118  do i = 1, ngood
11119  ! reprise coordonnees spaciales pour calcul des champs
11120  xc(i) = xcp(i)
11121  yc(i) = ycp(i)
11122  zc(i) = zcp(i)
11123  ! principal ellipsoid
11124  call intga(i, 0)
11125  ext = ex
11126  eyt = ey
11127  ezt = ez
11128  ! second ellipsoid
11129  call intga(i, 1)
11130  ext = ext + ex
11131  eyt = eyt + ey
11132  ezt = ezt + ez
11133  ! third ellipsoid
11134  if (inint==3) then
11135  call intga(i, 2)
11136  ext = ext + ex
11137  eyt = eyt + ey
11138  ezt = ezt + ez
11139  end if
11140  ! calculate kick in x',y' and z' (energy)
11141  ! isochronism correction
11142  eztp = ezt*cos(apl) - ext*sin(apl)
11143  extp = ezt*sin(apl) + ext*cos(apl)
11144  ezt = eztp
11145  ext = extp
11146  gsc = f(7, i)/xmat
11147  gsct = gsct + gsc
11148  igsct = igsct + 1
11149  bsc = sqrt(1.-1./(gsc*gsc))
11150  dxp = const2*ext*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
11151  dyp = const2*eyt*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
11152  dw = const3*ezt*dz/gsc
11153  if (.not. iesp) then
11154  ! load the entrance beam parameters for cavities or gaps
11155  do js = 1, 7
11156  f(js, i) = fs(js, i)
11157  end do
11158  f(3, i) = f(3, i) + dxp*1000.
11159  f(5, i) = f(5, i) + dyp*1000.
11160  f(2, i) = f(2, i) - dz1*dxp*100.*xpsc
11161  f(4, i) = f(4, i) - dz1*dyp*100.*xpsc
11162  ! omment f(2,i)=f(2,i)-dz1*dxp*100.
11163  ! omment f(4,i)=f(4,i)-dz1*dyp*100.
11164  dwp(i) = dw
11165  else
11166  f(3, i) = f(3, i) + dxp*1000.
11167  f(5, i) = f(5, i) + dyp*1000.
11168  f(7, i) = f(7, i) + dw
11169  end if
11170  end do
11171  return
11172  end subroutine schermi
11173  ! *******************************************************************
11174  ! SUBROUTINE entre
11175  ! define some input beam characteristics
11176  ! uem : Rest mass in MeV
11177 
11178  ! proton:938.27231 MeV
11179  ! H_ :939.3145 MeV
11180  ! mesons:33.9093 MeV
11181  ! pions :139.5685 MeV
11182  ! kaons :493.667 MeV
11183  ! electrons : 0.511 MeV
11184 
11185  ! atm : Atomic number
11186  ! qst : charge
11187 
11188  ! enedep: Kinetic energy
11189  ! tofini: Time of flight
11190 
11191  ! REMARK : After INPUT the reference coincides with the c.o.g.
11192  ! *******************************************************************
11193  subroutine entre
11194  implicit real *8(a-h, o-z)
11195  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
11196  common /consta/vl, pi, xmat, rpel, qst
11197  common /speda/dave, idave
11198  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
11199  common /dyn/tref, vref
11200  common /dyni/vrefi, trefi, fhinit, acpt
11201  common /faisc/f(10, iptsz), imax, ngood
11202  common /objet/fo(9, iptsz), imaxo
11203  common /histo/centre(6)
11204  common /qmoyen/qmoy
11205  common /rigid/boro
11206  common /mastrp/xma(2, 2), xmb(2, 2), xmc(2, 2)
11207  common /stis/suryth, surzph, enedep, ecogde, testca
11208  common /etcom/cog(8), exten(17), fd(iptsz)
11209  common /tapes/in, ifile, meta
11210  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
11211  common /tilt/tipha, tix, tiy, shifw, shifp
11212  common /newtlt/twissa(3), itwiss
11213  common /tof/tofini
11214  common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
11215  common /mcs/imcs, ncstat, cstat(20)
11216  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
11217  common /trace3e/tracebi(6), traceei(3)
11218  character *128 trace3h, trace3t, tif
11219  logical dave
11220  ! dimension foo(9)
11221  dave = .false.
11222  read (in, *) uem, atm, qst
11223  if (ncstat==1) cstat(1) = qst
11224  ! input energy(MeV) and initial time of flight(deg)
11225  read (in, *) enedep, tofini
11226  ! if icog=0 reference (vref,tref) is not cog
11227  ! if icog=1 reference (vref,tref) is cog
11228  ! --- xmat= rest mass
11229  xmat = uem*atm
11230  write (16, 101) uem, atm, xmat, qst
11231 101 format (' **** unit mass: ', e12.5, ' MeV mass units: ', f5.1, ' rest mass: ', e12.5, ' MeV charge ', f4.1)
11232  write (16, 102) enedep, tofini
11233 102 format (' **** energy: ', e12.5, ' MeV initial tof: ', e12.5, ' deg')
11234  tofini = tofini*pi/(180.*fh)
11235  gdep = enedep/xmat + 1.
11236  bdep = sqrt(1.-1./(gdep*gdep))
11237 
11238  tracebi(6) = tracebi(6)*sqrt(atm)
11239  write (tif, 901)(tracebi(i), i=1, 6)
11240 901 format (' BEAMI(1)= ', 5(f12.6,1x), f12.4)
11241  kt3h = kt3h + 1
11242  trace3h(kt3h) = tif
11243  traceei(3) = traceei(3)/sqrt(atm)
11244  write (tif, 902)(traceei(i), i=1, 3)
11245 902 format (' EMITI(1)= ', f12.6, 1x, f12.6, 1x, f12.4)
11246  kt3h = kt3h + 1
11247  trace3h(kt3h) = tif
11248 
11249  write (tif, 903) uem*atm/qst, fhinit/2./pi/1.e6
11250 903 format (' ER= ', e16.7, ', Q=1 FREQ= ', e14.7)
11251  kt3h = kt3h + 1
11252  trace3h(kt3h) = tif
11253  write (tif, 7001) enedep/qst
11254 7001 format (' W= ', f12.4)
11255  kt3h = kt3h + 1
11256  trace3h(kt3h) = tif
11257  ! fo(index,i), index=1 initial particle # ,
11258  ! index=2 x
11259  ! index=3 xp
11260  ! index=4 y
11261  ! index=5 yp
11262  ! index=6 time of flight (tof)
11263  ! index=7 energy
11264  ! index=8 if = 0 , then particle is lost
11265  ! index=9 charge
11266  ! i= particle #
11267  do i = 1, ngood
11268  ! if itwiss=1, apply tofini in tiltbm routine
11269  if (itwiss/=1) fo(6, i) = fo(6, i) + tofini
11270  fo(9, i) = qst
11271  fo(7, i) = enedep + fo(1, i) + xmat
11272  if (fo(7,i)<xmat) fo(7, i) = xmat
11273  fo(1, i) = float(i)
11274  end do
11275  ! --- the reference particle and the cog coincide
11276  bref = 0.
11277  tref = 0.
11278  encog = 0.
11279  do i = 1, ngood
11280  encog = encog + fo(7, i)
11281  gai = fo(7, i)/xmat
11282  bref = bref + sqrt(1.-1/(gai*gai))
11283  tref = tref + fo(6, i)
11284  end do
11285  encog = encog/float(ngood)
11286  bref = bref/float(ngood)
11287  vref = bref*vl
11288  tref = tref/float(ngood)
11289  vrefi = vref
11290  trefi = tref
11291  ! pack the table f(,) of the current beam
11292  do i = 1, ngood
11293  do j = 1, 9
11294  f(j, i) = fo(j, i)
11295  end do
11296  end do
11297  ! momentum of the reference (i.e. the c.o.g.)
11298  gcog = 1./sqrt(1.-bref*bref)
11299  boro = 3.3356*xmat*bref*gcog/abs(qst)
11300  write (16, 3450) boro
11301 3450 format (' **** momentum of c.o.g. (kG.cm): ', e12.5)
11302  if (itwiss==1) then
11303  ! Beam was defined in MCOBJET with Twiss parameters
11304  ! call TILTBM to apply Twiss alpha
11305  tipha = twissa(3)
11306  tix = twissa(1)
11307  tiy = twissa(2)
11308  shifw = .000000
11309  shifp = .000000
11310  icg = 1
11311  call tiltbm(icg)
11312  ! write the input beam in file 'input.beam'
11313  dum = 0.
11314  write (11, *) ngood, dum, fh/(2000000.*pi)
11315  do i = 1, ngood
11316  f(2, i) = f(2, i) + centre(2)
11317  f(3, i) = f(3, i) + centre(3)
11318  f(4, i) = f(4, i) + centre(4)
11319  f(5, i) = f(5, i) + centre(5)
11320  f(6, i) = f(6, i) + centre(6)
11321  f(7, i) = f(7, i) + centre(1)
11322  etphas = fh*(f(6,i)-tref)
11323  etener = f(7, i) - xmat
11324  write (11, 777) f(2, i), f(3, i)/1000., f(4, i), f(5, i)/1000., etphas, etener
11325  end do
11326 777 format (6(f13.8,1x))
11327  else
11328  ! in case of itwiss.ne.1 apply CENTRE and write input beam in TILTBM
11329  tipha = 0.
11330  tix = 0.
11331  tiy = 0.
11332  shifw = .000000
11333  shifp = .000000
11334  icg = 1
11335  call tiltbm(icg)
11336  end if
11337  call emiprt(0)
11338  return
11339  end subroutine entre
11340  ! *******************************************************************
11341  ! SUBROUTINE monte
11342  ! random generation of the 6D coordinates of the cloud of particles
11343  ! LOI : 1 IMAX particles are generated randomly in three phase
11344  ! plane ellipse with uniform distribution in real space
11345  ! (x,y,z), then xp,yp, and zp from within each phase-plane
11346  ! ellipse. z,zp are converted to phi,w
11347  ! LOI : 2 IMAX particles are generated randomly in a six
11348  ! dimensional ellipsoid
11349  ! LOI : 3 IMAX particles are generated randomly in three phase
11350  ! plane ellipse in real space (x,y,z),with distribution
11351  ! corrresponding to an equilibrium stationary sphere at the
11352  ! limit of the of the current acceptable (see help_DYNAC).
11353  ! Then xp,yp, and zp from within each phase-plane for
11354  ! each phase-plane ellipse. z,zp are converted to phi,w
11355  ! LOI : 4 IMAX particles are generated randomly in a six
11356  ! dimensional ellipsoid from a distribution corresponding
11357  ! to an equilibrium stationary sphere
11358  ! LOI : 5 IMAX particles are generated randomly in a six
11359  ! dimensional cylinder (axis in z-direction)
11360  ! with uniform distribution in transverse directions
11361  ! LOI : 6 IMAX particles are generated randomly in a six
11362  ! dimensional cylinder (axis in z-direction)
11363  ! with gaussian distribution in transverse directions
11364  ! ITWISS=1 read Twiss parameters for emittance definition
11365  ! ITWISS<>1 reading emittance bounderies for upright ellips
11366 
11367  ! This routine uses the CERN random # routine RLUX (named ranlux in
11368  ! the CERN library)
11369  ! *******************************************************************
11370  subroutine monte
11371  implicit real *8(a-h, o-z)
11372  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
11373  common /dcspa/iesp
11374  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
11375  common /com4/cord(iptsz, 6)
11376  common /faisc/f(10, iptsz), imax, ngood
11377  common /objet/fo(9, iptsz), imaxo
11378  common /qmoyen/qmoy
11379  common /histo/centre(6)
11380  common /consta/vl, pi, xmat, rpel, qst
11381  common /tapes/in, ifile, meta
11382  common /ranec1/dummy(6)
11383  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
11384  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
11385  common /newtlt/twissa(3), itwiss
11386  common /dyni/vrefi, trefi, fhinit, acpt
11387  common /speda/dave, idave
11388  common /ragau/ntir
11389  ! ********************************************
11390  ! v28/04/2015
11391  common /fcont/ifcont
11392  logical ifcont
11393  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
11394  common /trace3e/tracebi(6), traceei(3)
11395  character *128 trace3h, trace3t, tif
11396  logical iesp, chasit, dave
11397  ! dimension fn(9,iptsz),foo(9),so(6),vecx(1)
11398  dimension vecx(1)
11399 
11400  read (in, *) loi, itwiss
11401  write (16, *) ' Generate particles based on law ', loi
11402  if (loi>6) then
11403  write (16, *) .gt.' ERROR in GEBEAM: law 6 invalid ! '
11404  stop
11405  end if
11406  read (in, *) fh, imax
11407  write (16, 102) fh
11408 102 format (//, 30x, ' FREQUENCY : ', e12.5, ' Hz', //)
11409  fh = fh*2.*pi
11410  fhinit = fh
11411  ! Center of the beam ellipsoid
11412  ! X X' Y Y' Z' Z
11413  read (in, *)(centre(j), j=2, 5), centre(1), centre(6)
11414  if (itwiss/=1) then
11415  read (in, *) ymax, tmax, zmax, pmax, dmax, ttmax
11416  kt3h = kt3h + 1
11417  trace3h(kt3h) = .NE.'ERROR: GEBEAM ITWISS1 not yet implemented'
11418  else
11419  read (in, *) alphax, betax, emitx
11420  read (in, *) alphay, betay, emity
11421  read (in, *) alphaz, betaz, emitz
11422  gammax = (1.+alphax*alphax)/betax
11423  gammay = (1.+alphay*alphay)/betay
11424  ymax = 0.1*sqrt(emitx/gammax)
11425  tmax = sqrt(emitx*gammax)
11426  zmax = 0.1*sqrt(emity/gammay)
11427  pmax = sqrt(emity*gammay)
11428  twissa(1) = -alphax*ymax
11429  twissa(2) = -alphay*zmax
11430  if (loi/=5) then
11431  gammaz = (1.+alphaz*alphaz)/betaz
11432  dmax = 0.001*sqrt(emitz*gammaz)
11433  ttmax = pi*sqrt(emitz/gammaz)/(fh*180.)
11434  twissa(3) = alphaz*sqrt(emitz/gammaz)
11435  end if
11436  if (loi>=5) then
11437  dmax = alphaz
11438  twissa(3) = 0.
11439  ttmax = pi/fh
11440  end if
11441  if (loi==6) then
11442  sig = betaz
11443  end if
11444  ! store parameters for trace3d, write them in ENTRE
11445  tracebi(1) = alphax
11446  tracebi(2) = betax
11447  tracebi(3) = alphay
11448  tracebi(4) = betay
11449  tracebi(5) = alphaz
11450  tracebi(6) = betaz
11451  traceei(1) = emitx
11452  traceei(2) = emity
11453  traceei(3) = emitz
11454  end if
11455  ! --- beam centre is activated in SUBROUTINE entre
11456  cph = centre(6)*fh*180/pi
11457  write (16, 123)(centre(j), j=2, 5), centre(1), centre(6), cph
11458 123 format (' *** Beam centre defined as:', /, 3x, 4x, ' Transverse direction :', /, 6x, ' HORZ PLANE X(CM) = ', &
11459  e12.5, ' XP(MRD) = ', e12.5, /, 6x, ' VERT PLANE Y(CM) = ', e12.5, ' YP(MRD) = ', e12.5, /, 4x, &
11460  ' LONGITUDINAL :', /, 5x, ' DELTA ENERGY(MeV) = ', e12.5, ' TIME(SEC) = ', e12.5, /, 41x, ' PHASE(DEG) = ', &
11461  e12.5, //)
11462  ptmax = ttmax*fh*180./pi
11463  if (itwiss/=1) then
11464  write (16, 99) ymax, tmax, zmax, pmax, dmax, ttmax, ptmax
11465 99 format (3x, ' *** Limits of the random distribution ', /, 4x, ' Transverse direction :', /, 6x, &
11466  ' HORZ PLANE X(CM) = ', e12.5, ' XP(MRD) = ', e12.5, /, 6x, ' VERT PLANE Y(CM) = ', e12.5, &
11467  ' YP(MRD) = ', e12.5, /, 4x, ' LONGITUDINAL :', /, 5x, ' DELTA ENERGY(MeV) = ', e12.5, &
11468  ' TIME(SEC) = ', e12.5, /, 41x, ' PHASE(DEG) = ', e12.5, //)
11469  else
11470  ! if(loi.eq.5) then
11471  if (loi>=5) then
11472  write (16, *) ' Beam distribution based on Twiss parameters'
11473  write (16, 199) alphax, betax, emitx, alphay, betay, emity
11474  write (16, 399) ptmax, dmax
11475 399 format (4x, ' Continuous beam in the longitudinal direction :', /, 6x, ' half phase length (deg): ', e12.5, /, &
11476  6x, ' half energy width (MeV): ', e12.5)
11477  ! continuous beam
11478  ifcont = .true.
11479  else
11480  write (16, *) ' Beam distribution based on Twiss parameters'
11481  write (16, 199) alphax, betax, emitx, alphay, betay, emity
11482 199 format (4x, ' Transverse direction :', /, 6x, ' Horz plane: alpha: ', e12.5, ' beta(mm/mrad): ', e12.5, &
11483  ' emit(pi*mm*mrad): ', e12.5, /, 6x, ' Vert plane: alpha: ', e12.5, ' beta(mm/mrad): ', e12.5, &
11484  ' emit(pi*mm*mrad): ', e12.5)
11485  write (16, 299) alphaz, betaz, emitz
11486 299 format (4x, ' Longitudinal direction :', /, 6x, ' alpha: ', e12.5, ' beta(deg/keV): ', e12.5, &
11487  ' emit(pi*deg*keV): ', e12.5)
11488  end if
11489  end if
11490  ! len : starting value of the random vector for the routine rlux
11491  len = 1
11492  do j = 1, 6
11493  cord(1, j) = 0.0
11494  end do
11495  if (loi==1) then
11496  do i = 2, imax
11497 150 continue
11498  call rlux(vecx, len)
11499  r1 = 2.*vecx(1) - 1.
11500  call rlux(vecx, len)
11501  r3 = 2.*vecx(1) - 1.
11502  call rlux(vecx, len)
11503  r6 = 2.*vecx(1) - 1.
11504  ! make round in x,y,z plane
11505  rho = r1**2 + r3**2 + r6**2
11506  if (rho>1) go to 150
11507 152 call rlux(vecx, len)
11508  r2 = 2.*vecx(1) - 1.
11509  ! make beam round in x,x' plane
11510  if ((r1*r1+r2*r2)>1.) go to 152
11511 153 call rlux(vecx, len)
11512  r4 = 2.*vecx(1) - 1.
11513  ! make beam round in y,yp plane
11514  if ((r4*r4+r3*r3)>1.) go to 153
11515 180 call rlux(vecx, len)
11516  r5 = 2.*vecx(1) - 1.
11517  ! make beam round in plane z, zp
11518  if ((r6*r6+r5*r5)>1.) go to 180
11519  ! store random numbers in preparation for rms correction
11520  cord(i, 1) = r1
11521  cord(i, 2) = r2
11522  cord(i, 3) = r3
11523  cord(i, 4) = r4
11524  cord(i, 5) = r5
11525  cord(i, 6) = r6
11526  end do
11527  end if
11528  if (loi==2) then
11529  do i = 2, imax
11530 1500 call rlux(vecx, len)
11531  r1 = 2.*vecx(1) - 1.
11532  call rlux(vecx, len)
11533  r2 = 2.*vecx(1) - 1.
11534  ! make round x,xp
11535  rho = r1*r1 + r2*r2
11536  if (rho>1) go to 1500
11537 1530 call rlux(vecx, len)
11538  r3 = 2.*vecx(1) - 1.
11539  call rlux(vecx, len)
11540  r4 = 2.*vecx(1) - 1.
11541  ! make beam round in y,yp plane
11542  if ((r4*r4+r3*r3)>1.) go to 1530
11543 1800 call rlux(vecx, len)
11544  r5 = 2.*vecx(1) - 1.
11545  call rlux(vecx, len)
11546  r6 = 2.*vecx(1) - 1.
11547  ! make beam round in plane z, zp
11548  if ((r6*r6+r5*r5)>1.) go to 1800
11549  ! make round x,xp,y,yp,z,zp
11550  rho = r1**2 + r2**2 + r3**2 + r4**2 + r5**2 + r6**2
11551  if (rho>1.0) go to 1500
11552  ! store random numbers in preparation for rms correction
11553  cord(i, 1) = r1
11554  cord(i, 2) = r2
11555  cord(i, 3) = r3
11556  cord(i, 4) = r4
11557  cord(i, 5) = r5
11558  cord(i, 6) = r6
11559  end do
11560  end if
11561  if (loi==3) then
11562  ntir = 24
11563  s = .2493
11564  am = 0.
11565  do i = 2, imax
11566 14 call gcern(len, s, am, vec)
11567  r1 = vec
11568  call gcern(len, s, am, vec)
11569  r3 = vec
11570  call gcern(len, s, am, vec)
11571  r6 = vec
11572  ! make round in x,y,z plane
11573  rho = r1**2 + r3**2 + r6**2
11574  if (rho>1) go to 14
11575 16 call gcern(len, s, am, vec)
11576  r2 = vec
11577  ! make beam round in x,x' plane
11578  if ((r1*r1+r2*r2)>1.) go to 16
11579 17 call gcern(len, s, am, vec)
11580  r4 = vec
11581  ! make beam round in y,yp plane
11582  if ((r4*r4+r3*r3)>1.) go to 17
11583 22 call gcern(len, s, am, vec)
11584  r5 = vec
11585  ! make beam round in plane z, zp
11586  if ((r6*r6+r5*r5)>1.) go to 22
11587  ! store random numbers in preparation for rms correction
11588  cord(i, 1) = r1
11589  cord(i, 2) = r2
11590  cord(i, 3) = r3
11591  cord(i, 4) = r4
11592  cord(i, 5) = r5
11593  cord(i, 6) = r6
11594  end do
11595  end if
11596  if (loi==4) then
11597  ntir = 12
11598  s = .2493
11599  am = 0.
11600  do i = 2, imax
11601 101 call gcern(len, s, am, vec)
11602  r1 = vec
11603  call gcern(len, s, am, vec)
11604  r2 = vec
11605  ! make beam round in x,xp plane
11606  rho = r1*r1 + r2*r2
11607  if (rho>1) go to 101
11608 112 call gcern(len, s, am, vec)
11609  r3 = vec
11610  call gcern(len, s, am, vec)
11611  r4 = vec
11612  ! make beam round in y,yp plane
11613  if ((r3*r3+r4*r4)>1.) go to 112
11614 113 call gcern(len, s, am, vec)
11615  r5 = vec
11616  call gcern(len, s, am, vec)
11617  r6 = vec
11618  ! make beam round in plane z, zp
11619  if ((r6*r6+r5*r5)>1.) go to 113
11620  ! store random numbers in preparation for rms correction
11621  ! make round x,xp,y,yp,z,zp
11622  rho = r1**2 + r2**2 + r3**2 + r4**2 + r5**2 + r6**2
11623  if (rho>1.0) go to 101
11624  cord(i, 1) = r1
11625  cord(i, 2) = r2
11626  cord(i, 3) = r3
11627  cord(i, 4) = r4
11628  cord(i, 5) = r5
11629  cord(i, 6) = r6
11630  end do
11631  end if
11632  if (loi==5) then
11633  do i = 2, imax
11634 1566 continue
11635  call rlux(vecx, len)
11636  r1 = 2.*vecx(1) - 1.
11637  call rlux(vecx, len)
11638  r3 = 2.*vecx(1) - 1.
11639  ! make round in x,y plane
11640  rho = r1**2 + r3**2
11641  if (rho>1) go to 1566
11642 1525 call rlux(vecx, len)
11643  r2 = 2.*vecx(1) - 1.
11644  ! make beam round in x,x' plane
11645  if ((r1*r1+r2*r2)>1.) go to 1525
11646 1535 call rlux(vecx, len)
11647  r4 = 2.*vecx(1) - 1.
11648  ! make beam round in y,yp plane
11649  if ((r4*r4+r3*r3)>1.) go to 1535
11650  ! make round x,xp,y,yp
11651  rho = r1**2 + r2**2 + r3**2 + r4**2
11652  if (rho>1.0) go to 1566
11653  ! *et*2010-11-23 do NOT make beam round in z,zp plane
11654  ! et1835 call rlux(vecx,len)
11655  call rlux(vecx, len)
11656  r5 = 2.*vecx(1) - 1.
11657  call rlux(vecx, len)
11658  r6 = 2.*vecx(1) - 1.
11659  ! et if((r6*r6+r5*r5).gt.1.) go to 1835
11660  ! store random numbers in preparation for rms correction
11661  cord(i, 1) = r1
11662  cord(i, 2) = r2
11663  cord(i, 3) = r3
11664  cord(i, 4) = r4
11665  cord(i, 5) = r5
11666  cord(i, 6) = r6
11667  end do
11668  end if
11669  if (loi==6) then
11670  ! Gaussian
11671  do i = 2, imax
11672  call rgaus2(sig, y1, y2, y3, y4)
11673  ! do NOT make beam gaussian in z,zp plane
11674  call rlux(vecx, len)
11675  r5 = 2.*vecx(1) - 1.
11676  call rlux(vecx, len)
11677  r6 = 2.*vecx(1) - 1.
11678 
11679  ! store random numbers in preparation for rms correction
11680  cord(i, 1) = y1
11681  cord(i, 2) = y2
11682  cord(i, 3) = y3
11683  cord(i, 4) = y4
11684  cord(i, 5) = r5
11685  cord(i, 6) = r6
11686  end do
11687  y1x = abs(cord(2,1))
11688  y2x = abs(cord(2,2))
11689  y3x = abs(cord(2,3))
11690  y4x = abs(cord(2,4))
11691  do i = 3, imax
11692  if (abs(cord(i,1))>y1x) y1x = abs(cord(i,1))
11693  if (abs(cord(i,2))>y2x) y2x = abs(cord(i,2))
11694  if (abs(cord(i,3))>y3x) y3x = abs(cord(i,3))
11695  if (abs(cord(i,4))>y4x) y4x = abs(cord(i,4))
11696  end do
11697  do i = 2, imax
11698  cord(i, 1) = cord(i, 1)/y1x
11699  cord(i, 2) = cord(i, 2)/y2x
11700  cord(i, 3) = cord(i, 3)/y3x
11701  cord(i, 4) = cord(i, 4)/y4x
11702  end do
11703  end if
11704  call corre(imax, imax)
11705  ! fimax=ttmax*fh*180./pi
11706  ! maximum extent in case of continous beam is +/-pi (i.e. +/-180 deg)
11707  tcorct = abs(.5*cord(2,6)*ttmax)
11708  ! in fo(1,) is stored the energy extent (MeV)
11709  do i = 2, imax
11710  fo(1, i) = .5*cord(i, 5)*dmax
11711  fo(2, i) = .5*cord(i, 1)*ymax
11712  fo(3, i) = .5*cord(i, 2)*tmax
11713  fo(4, i) = .5*cord(i, 3)*zmax
11714  fo(5, i) = .5*cord(i, 4)*pmax
11715  fo(6, i) = .5*cord(i, 6)*ttmax
11716  if (abs(fo(6,i))>tcorct) tcorct = abs(fo(6,i))
11717  end do
11718  ! first particle
11719  ! ccc imax=imax+1
11720  ichas(1) = 1
11721  fo(8, 1) = 1.
11722  do j = 1, 6
11723  fo(j, 1) = 0.
11724  end do
11725  ! if(loi.ne.5) then
11726  if (loi<5) then
11727  do i = 2, imax
11728  fo(8, i) = 1
11729  ichas(i) = 1
11730  end do
11731  else
11732  ! correct the phase length for a continuous beam (force +/- 180 deg)
11733  tcorct = ttmax/tcorct
11734  do i = 2, imax
11735  fo(8, i) = 1
11736  ichas(i) = 1
11737  fo(6, i) = fo(6, i)*tcorct
11738  end do
11739  end if
11740  ngood = imax
11741  imaxo = imax
11742  write (16, 8) loi, imax
11743 8 format (8x, ' ****law ', i2, ' with ', i6, ' particles', /)
11744  return
11745  end subroutine monte
11746  ! *******************************************************************
11747  ! subroutine rgaus2(sigma,y1,y2,y3,y4)
11748  ! called by subroutine MONTE
11749  ! *******************************************************************
11750  subroutine rgaus2(sigma, y1, y2, y3, y4)
11751  implicit real *8(a-h, o-z)
11752  dimension vecx(1)
11753 
11754  len = 1
11755  do while ((w1>=1.0) .or. (w1==0.))
11756  call rlux(vecx, len)
11757  x1 = 2.0*vecx(1) - 1.0
11758  call rlux(vecx, len)
11759  x3 = 2.0*vecx(1) - 1.0
11760  w1 = x1*x1 + x3*x3
11761  end do
11762  do while ((w2>=1.0) .or. (w2==0.))
11763  call rlux(vecx, len)
11764  x2 = 2.0*vecx(1) - 1.0
11765  call rlux(vecx, len)
11766  x4 = 2.0*vecx(1) - 1.0
11767  w2 = x2*x2 + x4*x4
11768  end do
11769  w1 = sigma*sqrt((-2.0*log(w1))/w1)
11770  w2 = sigma*sqrt((-2.0*log(w2))/w2)
11771  y1 = x1*w1
11772  y2 = x2*w2
11773  y3 = x3*w1
11774  y4 = x4*w2
11775  return
11776  end subroutine rgaus2
11777  ! *******************************************************************
11778  ! SUBROUTINE rlux(RVEC,LENV)
11779  ! ranlux.f Rev 1.2 1997/09/22 13:45:47 mclareni
11780  ! Correct error in initializing RANLUX by using RLUXIN with the
11781  ! output of RLUXUT from a previous run.
11782  ! CERN Mathlib gen
11783 
11784  ! Subtract-and-borrow random number generator proposed by
11785  ! Marsaglia and Zaman, implemented by F. James with the name
11786  ! RCARRY in 1991, and later improved by Martin Luescher
11787  ! in 1993 to produce "Luxury Pseudorandom Numbers".
11788  ! Fortran 77 coded by F. James, 1993
11789 
11790  ! LUXURY LEVELS.
11791  ! ------ ------ The available luxury levels are:
11792 
11793  ! level 0 (p=24): equivalent to the original RCARRY of Marsaglia
11794  ! and Zaman, very long period, but fails many tests.
11795  ! level 1 (p=48): considerable improvement in quality over level 0,
11796  ! now passes the gap test, but still fails spectral test.
11797  ! level 2 (p=97): passes all known tests, but theoretically still
11798  ! defective.
11799  ! level 3 (p=223): DEFAULT VALUE. Any theoretically possible
11800  ! correlations have very small chance of being observed.
11801  ! level 4 (p=389): highest possible luxury, all 24 bits chaotic.
11802 
11803  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
11804  ! Calling sequences for RANLUX: ++
11805  ! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++
11806  ! 32-bit random floating point numbers between ++
11807  ! zero (not included) and one (also not incl.). ++
11808  ! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++
11809  ! one 32-bit integer INT and sets Luxury Level LUX ++
11810  ! which is integer between zero and MAXLEV, or if ++
11811  ! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++
11812  ! should be set to zero unless restarting at a break++
11813  ! point given by output of RLUXAT (see RLUXAT). ++
11814  ! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
11815  ! which can be used to restart the RANLUX generator ++
11816  ! at the current point by calling RLUXGO. K1 and K2++
11817  ! specify how many numbers were generated since the ++
11818  ! initialization with LUX and INT. The restarting ++
11819  ! skips over K1+K2*E9 numbers, so it can be long.++
11820  ! A more efficient but less convenient way of restarting is by: ++
11821  ! CALL RLUXIN(ISVEC) restarts the generator from vector ++
11822  ! ISVEC of 25 32-bit integers (see RLUXUT) ++
11823  ! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++
11824  ! 32-bit integer seeds, to be used for restarting ++
11825  ! ISVEC must be dimensioned 25 in the calling program ++
11826  ! *******************************************************************
11827  subroutine rlux(rvec, lenv)
11828  implicit real *8(a-h, o-z)
11829  dimension rvec(lenv)
11830  ! DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
11831  dimension seeds(24), iseeds(24)
11832  parameter(maxlev=4, lxdflt=3)
11833  dimension ndskip(0:maxlev)
11834  dimension next(24)
11835  parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
11836  parameter(itwo24=2**24, icons=2147483563)
11837  save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
11838  save nskip, ndskip, in24, next, kount, mkount, inseed
11839  integer luxlev
11840  logical notyet
11841  data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
11842  data i24, j24, carry/24, 10, 0./
11843  ! default
11844  ! Luxury Level 0 1 2 *3* 4
11845  data ndskip/0, 24, 73, 199, 365/
11846  ! orresponds to p=24 48 97 223 389
11847  ! time factor 1 2 3 6 10 on slow workstation
11848  ! 1 1.5 2 3 5 on fast mainframe
11849 
11850  ! NOTYET is .TRUE. if no initialization has been performed yet.
11851  ! Default Initialization by Multiplicative Congruential
11852  if (notyet) then
11853  notyet = .false.
11854  jseed = jsdflt
11855  inseed = jseed
11856  write (16, '(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ', jseed
11857  luxlev = lxdflt
11858  nskip = ndskip(luxlev)
11859  lp = nskip + 24
11860  in24 = 0
11861  kount = 0
11862  mkount = 0
11863  write (16, '(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', luxlev, ' p =', lp
11864  twom24 = 1.
11865  do i = 1, 24
11866  twom24 = twom24*0.5
11867  k = jseed/53668
11868  jseed = 40014*(jseed-k*53668) - k*12211
11869  if (jseed<0) jseed = jseed + icons
11870  iseeds(i) = mod(jseed, itwo24)
11871  end do
11872  twom12 = twom24*4096.
11873  do i = 1, 24
11874  seeds(i) = real(iseeds(i))*twom24
11875  next(i) = i - 1
11876  end do
11877  next(1) = 24
11878  i24 = 24
11879  j24 = 10
11880  carry = 0.
11881  if (seeds(24)==0.) carry = twom24
11882  end if
11883 
11884  ! The Generator proper: "Subtract-with-borrow",
11885  ! as proposed by Marsaglia and Zaman,
11886  ! Florida State University, March, 1989
11887 
11888  do ivec = 1, lenv
11889  uni = seeds(j24) - seeds(i24) - carry
11890  if (uni<0.) then
11891  uni = uni + 1.0
11892  carry = twom24
11893  else
11894  carry = 0.
11895  end if
11896  seeds(i24) = uni
11897  i24 = next(i24)
11898  j24 = next(j24)
11899  rvec(ivec) = uni
11900  ! small numbers (with less than 12 "significant" bits) are "padded".
11901  if (uni<twom12) then
11902  rvec(ivec) = rvec(ivec) + twom24*seeds(j24)
11903  ! and zero is forbidden in case someone takes a logarithm
11904  if (rvec(ivec)==0.) rvec(ivec) = twom24*twom24
11905  end if
11906  ! Skipping to luxury. As proposed by Martin Luscher.
11907  in24 = in24 + 1
11908  if (in24==24) then
11909  in24 = 0
11910  kount = kount + nskip
11911  do isk = 1, nskip
11912  uni = seeds(j24) - seeds(i24) - carry
11913  if (uni<0.) then
11914  uni = uni + 1.0
11915  carry = twom24
11916  else
11917  carry = 0.
11918  end if
11919  seeds(i24) = uni
11920  i24 = next(i24)
11921  j24 = next(j24)
11922  end do
11923  end if
11924  end do
11925  kount = kount + lenv
11926  if (kount>=igiga) then
11927  mkount = mkount + 1
11928  kount = kount - igiga
11929  end if
11930  return
11931  end subroutine rlux
11932  ! *******************************************************************
11933  ! SUBROUTINE RLUXIN(ISDEXT)
11934  ! ranlux.f Rev 1.2 1997/09/22 13:45:47 mclareni
11935  ! Correct error in initializing RANLUX by using RLUXIN with the
11936  ! output of RLUXUT from a previous run.
11937  ! CERN Mathlib gen
11938  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
11939  ! RLUXIN(ISVEC) restarts the generator from vector ++
11940  ! ISVEC of 25 32-bit integers (see RLUXUT) ++
11941  ! ISVEC must be dimensioned 25 in the calling program ++
11942  ! *******************************************************************
11943  subroutine rluxin(isdext)
11944  implicit real *8(a-h, o-z)
11945  dimension seeds(24), isdext(25)
11946  parameter(maxlev=4, lxdflt=3)
11947  dimension ndskip(0:maxlev)
11948  dimension next(24)
11949  parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
11950  parameter(itwo24=2**24, icons=2147483563)
11951  save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
11952  save nskip, ndskip, in24, next, kount, mkount, inseed
11953  integer luxlev
11954  logical notyet
11955  data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
11956  data i24, j24, carry/24, 10, 0./
11957  ! default
11958  ! Luxury Level 0 1 2 *3* 4
11959  data ndskip/0, 24, 73, 199, 365/
11960  ! orresponds to p=24 48 97 223 389
11961  ! time factor 1 2 3 6 10 on slow workstation
11962  ! 1 1.5 2 3 5 on fast mainframe
11963 
11964 
11965  ! Entry to input and float integer seeds from previous run
11966  notyet = .false.
11967  twom24 = 1.
11968  do i = 1, 24
11969  next(i) = i - 1
11970  twom24 = twom24*0.5
11971  end do
11972  next(1) = 24
11973  twom12 = twom24*4096.
11974  write (16, '(A)') 'FULL INITIALIZATION OF RANLUX WITH 25', ' INTEGERS'
11975  write (16, '(5X,5I12)') isdext
11976  do i = 1, 24
11977  seeds(i) = real(isdext(i))*twom24
11978  end do
11979  carry = 0.
11980  if (isdext(25)<0) carry = twom24
11981  isd = iabs(isdext(25))
11982  i24 = mod(isd, 100)
11983  isd = isd/100
11984  j24 = mod(isd, 100)
11985  isd = isd/100
11986  in24 = mod(isd, 100)
11987  isd = isd/100
11988  luxlev = isd
11989  if (luxlev<=maxlev) then
11990  nskip = ndskip(luxlev)
11991  write (6, '(A,I2)') 'RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', luxlev
11992  else if (luxlev>=24) then
11993  nskip = luxlev - 24
11994  write (6, '(A,I5)') 'RANLUX P-VALUE SET BY RLUXIN TO:', luxlev
11995  else
11996  nskip = ndskip(maxlev)
11997  write (6, '(A,I5)') 'RANLUX ILLEGAL LUXURY RLUXIN: ', luxlev
11998  luxlev = maxlev
11999  end if
12000  inseed = -1
12001  return
12002  end subroutine rluxin
12003  ! *******************************************************************
12004  ! SUBROUTINE RLUXUT(ISDEXT)
12005  ! CERN Mathlib gen
12006  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
12007  ! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++
12008  ! 32-bit integer seeds, to be used for restarting ++
12009  ! ISVEC must be dimensioned 25 in the calling program ++
12010  ! *******************************************************************
12011  subroutine rluxut(isdext)
12012  implicit real *8(a-h, o-z)
12013  dimension seeds(24), isdext(25)
12014  parameter(maxlev=4, lxdflt=3)
12015  dimension ndskip(0:maxlev)
12016  parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
12017  parameter(itwo24=2**24, icons=2147483563)
12018  save notyet, i24, j24, carry, seeds, luxlev
12019  save ndskip, in24, kount, mkount
12020  integer luxlev
12021  logical notyet
12022  data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
12023  data i24, j24, carry/24, 10, 0./
12024  ! default
12025  ! Luxury Level 0 1 2 *3* 4
12026  data ndskip/0, 24, 73, 199, 365/
12027  ! orresponds to p=24 48 97 223 389
12028  ! time factor 1 2 3 6 10 on slow workstation
12029  ! 1 1.5 2 3 5 on fast mainframe
12030 
12031 
12032  ! Entry to output seeds as integers
12033  do i = 1, 24
12034  isdext(i) = int(seeds(i)*twop12*twop12)
12035  end do
12036  isdext(25) = i24 + 100*j24 + 10000*in24 + 1000000*luxlev
12037  if (carry>0.) isdext(25) = -isdext(25)
12038  return
12039  end subroutine rluxut
12040  ! *******************************************************************
12041  ! SUBROUTINE RLUXAT(LOUT,INOUT,K1,K2)
12042  ! CERN Mathlib gen
12043  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
12044  ! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
12045  ! which can be used to restart the RANLUX generator ++
12046  ! at the current point by calling RLUXGO. K1 and K2++
12047  ! specify how many numbers were generated since the ++
12048  ! initialization with LUX and INT. The restarting ++
12049  ! skips over K1+K2*E9 numbers, so it can be long.++
12050  ! ISVEC must be dimensioned 25 in the calling program ++
12051  ! *******************************************************************
12052  subroutine rluxat(lout, inout, k1, k2)
12053  implicit real *8(a-h, o-z)
12054  parameter(maxlev=4, lxdflt=3)
12055  save notyet, luxlev
12056  save in24, kount, mkount, inseed
12057  integer luxlev
12058  logical notyet
12059  data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
12060  ! Entry to output the "convenient" restart point
12061  lout = luxlev
12062  inout = inseed
12063  k1 = kount
12064  k2 = mkount
12065  return
12066  end subroutine rluxat
12067  ! *******************************************************************
12068  ! SUBROUTINE RLUXGO(LUX,INS,K1,K2)
12069  ! CERN Mathlib gen
12070  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
12071  ! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++
12072  ! one 32-bit integer INT and sets Luxury Level LUX ++
12073  ! which is integer between zero and MAXLEV, or if ++
12074  ! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++
12075  ! should be set to zero unless restarting at a break++
12076  ! point given by output of RLUXAT (see RLUXAT). ++
12077  ! ISVEC must be dimensioned 25 in the calling program ++
12078  ! *******************************************************************
12079  subroutine rluxgo(lux, ins, k1, k2)
12080  implicit real *8(a-h, o-z)
12081  dimension seeds(24), iseeds(24)
12082  parameter(maxlev=4, lxdflt=3)
12083  dimension ndskip(0:maxlev)
12084  dimension next(24)
12085  parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
12086  parameter(itwo24=2**24, icons=2147483563)
12087  save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
12088  save nskip, ndskip, in24, next, kount, mkount, inseed
12089  integer luxlev
12090  logical notyet
12091  data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
12092  data i24, j24, carry/24, 10, 0./
12093  ! default
12094  ! Luxury Level 0 1 2 *3* 4
12095  data ndskip/0, 24, 73, 199, 365/
12096  ! orresponds to p=24 48 97 223 389
12097  ! time factor 1 2 3 6 10 on slow workstation
12098  ! 1 1.5 2 3 5 on fast mainframe
12099 
12100 
12101  ! Entry to initialize from one or three integers
12102  if (lux<0) then
12103  luxlev = lxdflt
12104  else if (lux<=maxlev) then
12105  luxlev = lux
12106  else if (lux<24 .or. lux>2000) then
12107  luxlev = maxlev
12108  write (6, '(A,I7)') 'RANLUX ILLEGAL LUXURY RLUXGO: ', lux
12109  else
12110  luxlev = lux
12111  do ilx = 0, maxlev
12112  if (lux==ndskip(ilx)+24) luxlev = ilx
12113  end do
12114  end if
12115  if (luxlev<=maxlev) then
12116  nskip = ndskip(luxlev)
12117  write (16, '(A,I2,A,I4)') 'RANLUX LUXURY LEVEL SET BY RLUXGO :', luxlev, ' P=', nskip + 24
12118  else
12119  nskip = luxlev - 24
12120  write (16, '(A,I5)') 'RANLUX P-VALUE SET BY RLUXGO TO:', luxlev
12121  end if
12122  in24 = 0
12123  if (ins<0) write (6, '(A)') ' Illegal initialization by RLUXGO, negative input seed'
12124  if (ins>0) then
12125  jseed = ins
12126  write (16, '(A,3I12)') 'RANLUX INITIALIZED BY ', 'RLUXGO FROM SEEDS', jseed, k1, k2
12127  else
12128  jseed = jsdflt
12129  write (16, '(A)') 'RANLUX INITIALIZED BY RLUXGO FROM DEFAULT', ' SEED'
12130  end if
12131  inseed = jseed
12132  notyet = .false.
12133  twom24 = 1.
12134  do i = 1, 24
12135  twom24 = twom24*0.5
12136  k = jseed/53668
12137  jseed = 40014*(jseed-k*53668) - k*12211
12138  if (jseed<0) jseed = jseed + icons
12139  iseeds(i) = mod(jseed, itwo24)
12140  end do
12141  twom12 = twom24*4096.
12142  do i = 1, 24
12143  seeds(i) = real(iseeds(i))*twom24
12144  next(i) = i - 1
12145  end do
12146  next(1) = 24
12147  i24 = 24
12148  j24 = 10
12149  carry = 0.
12150  if (seeds(24)==0.) carry = twom24
12151  ! If restarting at a break point, skip K1 + IGIGA*K2
12152  ! Note that this is the number of numbers delivered to
12153  ! the user PLUS the number skipped (if luxury .GT. 0).
12154  kount = k1
12155  mkount = k2
12156  if (k1+k2/=0) then
12157  do iouter = 1, k2 + 1
12158  inner = igiga
12159  if (iouter==k2+1) inner = k1
12160  do isk = 1, inner
12161  uni = seeds(j24) - seeds(i24) - carry
12162  if (uni<0.) then
12163  uni = uni + 1.0
12164  carry = twom24
12165  else
12166  carry = 0.
12167  end if
12168  seeds(i24) = uni
12169  i24 = next(i24)
12170  j24 = next(j24)
12171  end do
12172  end do
12173  ! Get the right value of IN24 by direct calculation
12174  in24 = mod(kount, nskip+24)
12175  if (mkount>0) then
12176  izip = mod(igiga, nskip+24)
12177  izip2 = mkount*izip + in24
12178  in24 = mod(izip2, nskip+24)
12179  end if
12180  ! Now IN24 had better be between zero and 23 inclusive
12181  if (in24>23) then
12182  write (6, '(A/A,3I11,A,I5)') ' Error in RESTARTING with RLUXGO:', ' The values', ins, k1, k2, &
12183  ' cannot occur at luxury level', luxlev
12184  in24 = 0
12185  end if
12186  end if
12187  return
12188  end subroutine rluxgo
12189  ! *******************************************************************
12190  ! SUBROUTINE gcern(len,s,am,v)
12191  ! generateur aleatoire selon une loi normale
12192  ! s : ecart-type de la distribution
12193  ! am: moyenne de ladistribution
12194  ! v : nombre aléatoire selon la loi normale
12195  ! *******************************************************************
12196  subroutine gcern(len, s, am, v)
12197  implicit real *8(a-h, o-z)
12198  common /ragau/ntir
12199  dimension vecx(1)
12200 
12201  a = 0.
12202  do i = 1, ntir
12203  call rlux(vecx, len)
12204  y = vecx(1)
12205  a = a + y
12206  end do
12207  v = (a-float(ntir)/2.)*s + am
12208  return
12209  end subroutine gcern
12210  ! *******************************************************************
12211  ! SUBROUTINE adjrfq
12212  ! read the coordinates of particles from file
12213  ! *******************************************************************
12214  subroutine adjrfq
12215  implicit real *8(a-h, o-z)
12216  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12217  common /consta/vl, pi, xmat, rpel, qst
12218  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
12219  common /speda/dave, idave
12220  common /dyn/tref, vref
12221  common /faisc/f(10, iptsz), imax, ngood
12222  common /objet/fo(9, iptsz), imaxo
12223  common /qmoyen/qmoy
12224  common /rigid/boro
12225  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
12226  common /etcom/cog(8), exten(17), fd(iptsz)
12227  common /tapes/in, ifile, meta
12228  common /isxpyp/iflag
12229  common /mcs/imcs, ncstat, cstat(20)
12230  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12231  common /dyni/vrefi, trefi, fhinit, acpt
12232  common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
12233  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
12234  common /trace3e/tracebi(6), traceei(3)
12235  common /t3dfld/fldctr(15), zend(15), t3d
12236  logical t3d
12237  character *128 trace3h, trace3t, tif
12238  logical dave
12239 
12240  read (in, *) iflag
12241  if (iflag==0 .or. iflag==100) write (16, *) 'Standard file, phase in rad'
12242  if (iflag==1 .or. iflag==101) write (16, *) 'File with charge state and rest ', 'mass, phase in rad'
12243  if (iflag==2 .or. iflag==102) write (16, *) 'File with several charge states', ', phase in rad'
12244  if (iflag==10 .or. iflag==110) write (16, *) 'Standard file, phase in ns'
12245  if (iflag==11 .or. iflag==111) write (16, *) 'File with charge state and rest', ' mass, phase in ns'
12246  if (iflag==12 .or. iflag==112) write (16, *) 'File with several charge states', ', phase in ns'
12247  ! --- input: freq.(MHertz) tofini: phase offset (deg) to be applied both to the reference and the beam
12248  read (in, *) freq, tofini
12249  write (16, *) 'Frequency [MHz]:', freq
12250  fh = 2.*pi*freq*1.e06
12251  fhinit = fh
12252  read (in, *) uem, atm
12253  xmat = uem*atm
12254  ! --- reference:
12255  ! enedep:energy(MeV), qst: charge of the reference
12256  ! when iflag =0 or iflag = 1 qst is the charge of the beam
12257  read (in, *) enedep, qst
12258  tofini = tofini*pi/(180.*fh)
12259  gdep = enedep/xmat + 1.
12260  bdep = sqrt(1.-1./(gdep*gdep))
12261  vref = bdep*vl
12262  vrefi = vref
12263  tref = tofini
12264  trefi = tofini
12265  ncstat = 1
12266  boro = 3.3356*xmat*bdep*gdep/qst
12267  write (16, 101) uem, atm, qst, tofini, enedep, boro
12268 101 format (' **** unit mass: ', e12.5, ' MeV, mass units: ', f6.1, /, ' **** reference charge ', f4.1, &
12269  ' time of flight ', e12.5, ' sec', /, ' **** reference : energy ', e12.5, ' MeV momentum ', e12.5, ' kG.cm')
12270 
12271  read (55, *) imax, dum, dum
12272  if (imax+2>iptsz) then
12273  write (16, *) 'too many particles '
12274  stop
12275  end if
12276  ! iflag = 0 standard file:f(1,)=x, f(2,)=xp, f(3,)=y, f(4,)=yp, f(5,)=phase, f(6,)=kinetic energy
12277  if (iflag==0 .or. iflag==10) read (55, *)((f(i,j),i=1,6), j=1, imax)
12278  ! iflag = 1 File with rest mass: f(1,)=x, f(2,)=xp, f(3,)=y, f(4,)=yp, f(5,)=phase, f(6,)=kinetic energy, dum1,
12279  ! dum2
12280  if (iflag==1 .or. iflag==11) read (55, *)((f(i,j),i=1,6), dum1, dum2, j=1, imax)
12281  ! iflag = 2 beam with different charges: f(7,) = charge; figure out how many different ones there are and store
12282  ! them
12283  if (ncstat==1) cstat(1) = qst
12284  if (iflag==2 .or. iflag==12) then
12285  ncstat = 1
12286  read (55, *)(f(i,1), i=1, 7)
12287  cstat(1) = f(7, 1)
12288  do j = 2, imax
12289  read (55, *)(f(i,j), i=1, 7)
12290  mcstat = 0
12291  do k = 1, ncstat
12292  if (f(7,j)==cstat(k)) then
12293  mcstat = 1
12294  end if
12295  end do
12296  if (mcstat==0) then
12297  ncstat = ncstat + 1
12298  cstat(ncstat) = f(7, j)
12299  end if
12300  end do
12301  write (16, *) 'Number of charge states: ', ncstat
12302  write (16, *) 'Charge states: ', (cstat(j), j=1, ncstat)
12303  if (ncstat>1) imcs = 1
12304  end if
12305  call intfac(tofini)
12306  if (t3d) then
12307  tracebi(6) = tracebi(6)*sqrt(atm)
12308  write (tif, 901)(tracebi(i), i=1, 6)
12309 901 format (' BEAMI(1)= ', 5(f12.6,1x), f12.4)
12310  kt3h = kt3h + 1
12311  trace3h(kt3h) = tif
12312  traceei(3) = traceei(3)/sqrt(atm)
12313  write (tif, 902)(traceei(i), i=1, 3)
12314 902 format (' EMITI(1)= ', f12.6, 1x, f12.6, 1x, f12.4)
12315  kt3h = kt3h + 1
12316  trace3h(kt3h) = tif
12317  write (tif, 903) uem*atm/qst, fhinit/2./pi/1.e6
12318 903 format (' ER= ', e16.7, ', Q=1 FREQ= ', e14.7)
12319  kt3h = kt3h + 1
12320  trace3h(kt3h) = tif
12321  write (tif, 7001) enedep/qst
12322 7001 format (' W= ', f12.4)
12323  kt3h = kt3h + 1
12324  trace3h(kt3h) = tif
12325  end if
12326  return
12327  end subroutine adjrfq
12328  ! *******************************************************************
12329  ! SUBROUTINE intfac(tofini)
12330  ! convert the particles coordinates to DYNAC units
12331  ! *******************************************************************
12332  subroutine intfac(tofini)
12333  implicit real *8(a-h, o-z)
12334  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12335  common /etcom/cog(8), exten(17), fd(iptsz)
12336  common /shif/dtiph, shift
12337  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12338  common /faisc/f(10, iptsz), imax, ngood
12339  common /objet/fo(9, iptsz), imaxo
12340  common /qmoyen/qmoy
12341  common /rigid/boro
12342  common /dyn/tref, vref
12343  common /consta/vl, pi, xmat, rpel, qst
12344  common /tapes/in, ifile, meta
12345  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
12346  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
12347  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
12348  common /speda/dave, idave
12349  common /isxpyp/iflag
12350  common /mcs/imcs, ncstat, cstat(20)
12351  dimension foo(20, 9), ndp(20)
12352  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
12353  common /trace3e/tracebi(6), traceei(3)
12354  common /t3dfld/fldctr(15), zend(15), t3d
12355  logical t3d
12356  character *128 trace3h, trace3t, tif
12357  logical shift, chasit, dave
12358  ! FH :INITIAL FREQENCY (hertz)
12359  ! Use frequency from part. dist. file to calculate f(6,i)
12360  ! iflag = 0 : standard file, phase in rad
12361  ! iflag = 1 : special file, phase in rad
12362  ! iflag = 2 : several charge states, phase in rad
12363  ! iflag = 10 : standard file, phase in ns
12364  ! iflag = 11 : special file, phase in ns
12365  ! iflag = 12 : several charge states, phase in ns
12366  imcs = 0
12367  if (iflag==2 .or. iflag==12) imcs = 1
12368  qmoy = qst
12369  j = 1
12370  ! the table fo(,) is built from the input beam stored in the table f(,)
12371  if (iflag<=2) then
12372  do i = 1, imax
12373  fo(7, i) = f(6, j) + xmat
12374  if (iflag<=1) fo(9, i) = qst
12375  if (iflag==2) fo(9, i) = f(7, i)
12376  ichas(i) = 1
12377  fo(8, i) = 1.
12378  fo(1, i) = float(j+1)
12379  fo(2, i) = f(1, j)
12380  fo(3, i) = f(2, j)*1000.
12381  fo(4, i) = f(3, j)
12382  fo(5, i) = f(4, j)*1000.
12383  fo(6, i) = tofini + f(5, j)/fh
12384  j = j + 1
12385  end do
12386  else
12387  do i = 1, imax
12388  fo(7, i) = f(6, j) + xmat
12389  if (iflag<=11) fo(9, i) = qst
12390  if (iflag==12) fo(9, i) = f(7, i)
12391  ichas(i) = 1
12392  fo(8, i) = 1.
12393  fo(1, i) = float(j+1)
12394  fo(2, i) = f(1, j)
12395  fo(3, i) = f(2, j)*1000.
12396  fo(4, i) = f(3, j)
12397  fo(5, i) = f(4, j)*1000.
12398  fo(6, i) = tofini + f(5, j)*1.e-09
12399  j = j + 1
12400  end do
12401  end if
12402  ! cog of the beam
12403  if (iflag==0 .or. iflag==1 .or. iflag==10 .or. iflag==11) then
12404  ! single charge state
12405  ndp(1) = imax
12406  do j = 2, 7
12407  foo(1, j) = 0.
12408  end do
12409  do i = 1, imax
12410  do j = 2, 7
12411  foo(1, j) = foo(1, j) + fo(j, i)
12412  end do
12413  end do
12414  else
12415  ! multi charge state
12416  kt3h = kt3h + 1
12417  trace3h(kt3h) = 'ERROR: RDBEAM reads more than 1 charge state'
12418  do k = 1, ncstat
12419  ndp(k) = 0
12420  do j = 2, 7
12421  foo(k, j) = 0.
12422  end do
12423  end do
12424  do i = 1, imax
12425  do k = 1, ncstat
12426  if (fo(9,i)==cstat(k)) then
12427  ndp(k) = ndp(k) + 1
12428  do j = 2, 7
12429  foo(k, j) = foo(k, j) + fo(j, i)
12430  end do
12431  end if
12432  end do
12433  end do
12434  end if
12435  do k = 1, ncstat
12436  do j = 2, 7
12437  foo(k, j) = foo(k, j)/float(ndp(k))
12438  end do
12439  end do
12440  ngood = imax
12441  if (iflag==0 .or. iflag==1 .or. iflag==10 .or. iflag==11) then
12442  ! --- COG
12443  gref = foo(1, 7)/xmat
12444  bref = sqrt(1.-1./(gref*gref))
12445  xe = (gref-1.)*xmat
12446  ! magnetic rigidity
12447  bor = 3.3356*xmat*bref*gref/qst
12448  write (16, *) '**** COG : energy ', xe, ' MeV momentum ', boro, ' kG.cm'
12449  else
12450  do k = 1, ncstat
12451  gref = foo(k, 7)/xmat
12452  bref = sqrt(1.-1./(gref*gref))
12453  xe = (gref-1.)*xmat
12454  ! magnetic rigidity
12455  bor = 3.3356*xmat*bref*gref/cstat(k)
12456  write (16, *) ' Q: ', cstat(k), ' COG : energy ', xe, ' MeV momentum ', bor, ' kG.cm'
12457  end do
12458  end if
12459  vrefi = vref
12460  trefi = tref
12461  ! now save data back to f
12462  do i = 1, ngood
12463  do k = 1, 9
12464  f(k, i) = fo(k, i)
12465  end do
12466  end do
12467  ! 9999 format(6(2x,e12.5))
12468  imaxo = ngood
12469  call emiprt(0)
12470  if (t3d) then
12471  call emit3d
12472  end if
12473  return
12474  end subroutine intfac
12475  ! *******************************************************************
12476  ! SUBROUTINE stapl(zpos)
12477  ! the statistics in EXT2
12478 
12479  ! sprfx(cm): 2.*sqrt( sum(x*x) )
12480  ! sprfy(cm): 2.*sqrt( sum(y*y) )
12481  ! sprfw: 2.*sqrt( sum(dp/p * dp/p) )*beta*beta =
12482  ! (energy spread)/(energy of c.o.g)
12483  ! sprfp(deg):2.*sqrt( sum(dphi * dphi) )
12484  ! sprfz(cm) : sqrt( sum(dt * dt) )
12485  ! sprfl(m) : t.o.f of the reference
12486  ! sprww(MeV):kinetic energy of the c.o.g
12487  ! eprfw(ns.keV) : longitudinal emittance
12488  ! eprnx(mm.mrad): normalized emittance in x-direction
12489  ! eprny(mm.mrad): normalized emittance in y-direction
12490  ! *******************************************************************
12491  subroutine stapl(zpos)
12492  implicit real *8(a-h, o-z)
12493  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12494  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
12495  common /pltprf1/sprww(3000), eprfw(3000), eprnx(3000), eprny(3000), sprfz(3000)
12496  common /pltprf2/sxmn(3000), sxmx(3000), symn(3000), symx(3000), stmn(3000), stmx(3000), spmn(3000), spmx(3000), &
12497  swmn(3000), swmx(3000), disprx(3000), dispry(3000), dispcx(3000), dispcy(3000)
12498  common /etcom/cog(8), exten(17), fd(iptsz)
12499  common /consta/vl, pi, xmat, rpel, qst
12500  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12501  common /faisc/f(10, iptsz), imax, ngood
12502  common /grot/rzot, izrot
12503  logical izrot
12504  ! izrot: logical flag set as .true. in the routine ZROTA
12505  if (izrot) call zrotap(-rzot)
12506  iarg = 0
12507  call cdg(iarg)
12508  encog = cog(1)
12509  gcog = encog/xmat
12510  bcog = sqrt(1.-1./(gcog*gcog))
12511  tcog = cog(3)
12512  call ext2(iarg)
12513  qdisp = 2.*sqrt(exten(1))
12514  qmd = exten(1)*exten(3) - exten(2)*exten(2)
12515  delw = encog*encog*bcog**4
12516  qmdv = qmd*delw
12517  sqmdv = 4.*pi*sqrt(qmdv)
12518  eprfw(iprf) = sqmdv*1.e12/(pi*fh)
12519  sprfx(iprf) = 2.*sqrt(exten(4))
12520  sprfy(iprf) = 2.*sqrt(exten(6))
12521  trqtx = exten(4)*exten(5) - exten(8)*exten(8)
12522  trqpy = exten(6)*exten(7) - exten(9)*exten(9)
12523  surxth = 4.*pi*sqrt(trqtx)
12524  suryph = 4.*pi*sqrt(trqpy)
12525  eprnx(iprf) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
12526  eprny(iprf) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
12527  ! horizontal and vertical dispersion in meter (w.r.t. reference)
12528  ! disprx(iprf)=0.01*exten(12)/exten(14)
12529  ! dispry(iprf)=0.01*exten(13)/exten(14)
12530  ! horizontal and vertical dispersion in meter (w.r.t. COG)
12531  dispcx(iprf) = 0.01*exten(15)/exten(17)
12532  dispcy(iprf) = 0.01*exten(16)/exten(17)
12533  trqfi = 0.
12534  tof = 0.
12535  chxmx = f(2, 1)
12536  chxmn = f(2, 1)
12537  chymx = f(4, 1)
12538  chymn = f(4, 1)
12539  chpmx = f(6, 1) - tcog
12540  chpmn = f(6, 1) - tcog
12541  chwmx = f(7, 1) - encog
12542  chwmn = f(7, 1) - encog
12543  do i = 1, ngood
12544  gpai = f(7, i)/xmat
12545  bpai = sqrt(1.-1./(gpai*gpai))
12546  fdp = (gpai*bpai)/(gcog*bcog) - 1.
12547  trqfi = trqfi + fdp*fdp
12548  tf = (tcog-f(6,i))*bpai*vl
12549  tof = tof + tf*tf
12550  if (f(2,i)>chxmx) chxmx = f(2, i)
12551  if (f(2,i)<chxmn) chxmn = f(2, i)
12552  if (f(4,i)>chymx) chymx = f(4, i)
12553  if (f(4,i)<chymn) chymn = f(4, i)
12554  if (f(6,i)-tcog>chpmx) then
12555  chpmx = f(6, i) - tcog
12556  chdmx = chpmx*fh*180./pi
12557  end if
12558  if (f(6,i)-tcog<chpmn) then
12559  chpmn = f(6, i) - tcog
12560  chdmn = chpmn*fh*180./pi
12561  end if
12562  if (f(7,i)-encog>chwmx) chwmx = f(7, i) - encog
12563  if (f(7,i)-encog<chwmn) chwmn = f(7, i) - encog
12564  end do
12565  trqfi = trqfi/float(ngood)
12566  tof = tof/float(ngood)
12567  sprfz(iprf) = sqrt(tof)
12568  cmult = (gcog+1.)/gcog
12569  sprfw(iprf) = 2.*sqrt(trqfi)*cmult
12570  sprfp(iprf) = 2.*sqrt(exten(3))*180./pi
12571  sprww(iprf) = cog(1) - xmat
12572  ! t.o.f of the reference in m
12573  sprfl(iprf) = zpos/1000.
12574  sprng(iprf) = ngood
12575  ! *et*2014-Sep-25 Add recording of min. and max. positions in x,y and z,z'
12576  sxmx(iprf) = chxmx*10.
12577  sxmn(iprf) = chxmn*10.
12578  symx(iprf) = chymx*10.
12579  symn(iprf) = chymn*10.
12580  stmx(iprf) = chpmx
12581  stmn(iprf) = chpmn
12582  spmx(iprf) = chdmx
12583  spmn(iprf) = chdmn
12584  swmx(iprf) = chwmx
12585  swmn(iprf) = chwmn
12586  ! evolve pointer iprf
12587  iprf = iprf + 1
12588  if (izrot) call zrotap(-rzot)
12589  return
12590  end subroutine stapl
12591  ! *******************************************************************
12592  ! SUBROUTINE eugwrt
12593  ! This routine writes the dynac.print file
12594  ! *******************************************************************
12595  subroutine eugwrt
12596  implicit real *8(a-h, o-z)
12597  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
12598  common /pltprf1/sprww(3000), eprfw(3000), eprnx(3000), eprny(3000), sprfz(3000)
12599  common /pltprf2/sxmn(3000), sxmx(3000), symn(3000), symx(3000), stmn(3000), stmx(3000), spmn(3000), spmx(3000), &
12600  swmn(3000), swmx(3000), disprx(3000), dispry(3000), dispcx(3000), dispcy(3000)
12601  ! l(m) x(mm) y(mm) z(deg) z(mm) Ex(mm.mrd) Ey(mm.mrd) Ez(KeV.ns) Wcog(MeV) xmin(mm) xmax(mm) ymin(mm) ymax(mm)
12602  ! tmin(ns) tmax(ns) pmin(deg) pmax(deg) wmin(MeV) wmax(MeV) Dxref(m) Dyref(m) Dxcog(m) Dycog(m)
12603  write (71, 99)
12604 99 format (1x, '# l(m) ', 1x, ' x(mm) ', 1x, ' y(mm) ', 3x, ' z(deg) ', 1x, ' z(mm) ', 2x, &
12605  'emx(mm.mrd)', 2x, 'emy(mm.mrd) ', 1x, 'emz(KeV.ns)', 2x, 'energy(MeV) ', 1x, '#particles', 2x, 'xmin(mm)', 5x, &
12606  'xmax(mm)', 5x, 'ymin(mm)', 5x, 'ymax(mm)', 5x, 'tmin(s)', 6x, 'tmax(s)', 5x, 'phmin(deg)', 4x, 'phmax(deg)', &
12607  3x, 'Wmin(MeV)', 4x, 'Wmax(MeV)', 4x, 'Dx(m)', 8x, 'Dy(m)')
12608  iprf1 = iprf - 1
12609  do i = 1, iprf1
12610  ! x and y: cm-->mm
12611  sprx = sprfx(i)*10./2.
12612  spry = sprfy(i)*10./2.
12613  sprp = sprfp(i)/2.
12614  sprz = sprfz(i)*10.
12615  write (71, 100) sprfl(i), sprx, spry, sprp, sprz, eprnx(i)/4., eprny(i)/4., eprfw(i), sprww(i), int(sprng(i)), &
12616  sxmn(i), sxmx(i), symn(i), symx(i), stmn(i), stmx(i), spmn(i), spmx(i), swmn(i), swmx(i), dispcx(i), dispcy(i)
12617  ! * disprx(i),dispry(i),dispcx(i),dispcy(i)
12618  end do
12619 100 format (9(1x,e12.5), 1x, i7, 3x, 12(1x,e12.5))
12620  ! 100 format(9(1x,e12.5),1x,i7,3x,14(1x,e12.5))
12621  return
12622  end subroutine eugwrt
12623  ! *******************************************************************
12624  ! SUBROUTINE etgap
12625  ! single cell of a DTL (CAVSC)
12626 
12627  ! etcell(1)=cell#, etcell(2)=energy (MeV), etcell(3)=beta
12628  ! etcell(4)=cell length (cm), etcell(5)=T, etcell(6)=TP,
12629  ! etcell (7)=S, etcell(8)=SP
12630  ! etcell(9)=quad length (cm), etcell (10)=quad. strength (kG/cm),
12631  ! etcell(11)=Eo (MV/m), etcell(12)= phase of RF at middle(deg),
12632  ! etcell(13)= actual length(cm), etcell(14)=TPP,
12633  ! etcell(15)=frequency (MHz), etcell(16)=field factor
12634  ! *******************************************************************
12635  subroutine etgap
12636  implicit real *8(a-h, o-z)
12637  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
12638  common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
12639  fhpar, nc
12640  common /posi/ist
12641  common /midgap/enmil, vapmi
12642  common /azmtch/dlg, xmcph, xmce
12643  common /azlist/icont, iprin
12644  common /itvole/itvol, imamin
12645  common /func/a(200), ylg, atte, ncel, nharm
12646  ! TRANSIT TIME COEFFICIENTS
12647  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
12648  common /ttfc1/t3k, t4k, s3k, s4k
12649  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
12650  common /jacob/gaks, gaps
12651  common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
12652  xk1ii, xk2ii
12653  common /faisc/f(10, iptsz), imax, ngood
12654  common /qmoyen/qmoy
12655  common /rigid/boro
12656  common /cdek/dwp(iptsz)
12657  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
12658  common /consta/vl, pi, xmat, rpel, qst
12659  common /dyn/tref, vref
12660  common /compt/nrres, nrtre, nrbunc, nrdbun
12661  common /compt1/ndtl, ncavmc, ncavnm
12662  common /fene/wdisp, wphas, wx, wy, rlim, ifw
12663  common /tapes/in, ifile, meta
12664  common /ranec1/dummy(6)
12665  common /etcom/cog(8), exten(17), fd(iptsz)
12666  common /speda/dave, idave
12667  common /shif/dtiph, shift
12668  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
12669  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
12670  common /dcspa/iesp
12671  common /fct/fakt
12672  common /mode/eflvl, rflvl
12673  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
12674  common /appel/irstay, ilost, iavp, ispcel
12675  common /posc/xpsc
12676  common /femt/iemgrw, iemqesg
12677  common /aerp/vphase, vfield, ierpf
12678  common /tofev/ttvols
12679  common /pstpla/tstp
12680  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
12681  character *128 trace3h, trace3t, tif
12682  ! --- synchronous particle:
12683  ! ***** DWRFS(MeV): energy gain
12684  ! ***** SPHRFS(rad): phase jump
12685  ! ***** PHRFS(rad):phase RF
12686  ! ***** common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
12687  logical iesp, irstay, iavp, ispcel, iemgrw
12688  character *1 cr
12689  ! SHIFT =TRUE: cog and synchronous particle are independent
12690  ! SHIFT =FALSE: cog and synchronous particle are coinciding
12691  logical shift, chasit, itvol, imamin, dave, ichaes
12692  dimension etcell(maxcell)
12693  ! --- iesp, irstay, ispcel logical flags used in the routines of space sharge computations
12694  ! iesp=false: accelerating element
12695  ! ispcel = .true.: space charge computation
12696  iesp = .false.
12697  irstay = .false.
12698  ispcel = .true.
12699  ilost = 0
12700  fact = 1.
12701  ndtl = ndtl + 1
12702  nrres = nrres + 1
12703  ! allow for print out on terminal of gap# on one and the same line
12704  cr = char(13)
12705  write (6, 8254) nrtre, ndtl, cr
12706 8254 format ('Transport element:', i5, ' Accelerating gap :', i5, a1, $)
12707  write (16, *) 'ACCELERATING GAP N :', ndtl
12708  read (in, *)(etcell(iet), iet=1, 16)
12709  fh = etcell(15)
12710  fakt = etcell(16)
12711  if (fakt==0.) fakt = 1.e-12
12712  fh = fh*2.*pi*1000000.
12713  ! --- YLG : CELL LENGTH (cm)
12714  ! --- YE0 : ELECTRIC FIELD (MV/cm)
12715  ylg = etcell(4)
12716  scdist = ylg
12717  ye0 = etcell(11)/100.
12718  ! TRANSIT TIME COEFFICIENTS (at the middle OF THE CELL)
12719  t0 = etcell(5)*ylg*ye0
12720  tp0 = -etcell(6)*ylg*ylg*ye0
12721  tpp0 = -etcell(14)*ylg*ylg*ylg*ye0
12722  ! TRANSIT TIME factors at the ENTRANCE OF THE CELL
12723  ! with kg=2*PI/ylg:
12724  ! TK0=T0*COS(kg*ylg/2) = -T0
12725  ! SK0=T0*SIN(kg*ylg/2) = 0
12726  ! TPK0=d(TK0)/dk
12727  ! SPK0=d(SK0)/dk
12728  ! TPPK0=d(TPK0)/dk
12729  ! SPPK0=d(SPK0)/dk
12730  tk0 = -t0
12731  sk0 = 0.
12732  tpk0 = -tp0
12733  spk0 = -ylg*t0/2.
12734  tppk0 = ylg*ylg*t0/4. - tpp0
12735  sppk0 = -ylg*tp0/2.
12736  tk = tk0
12737  t1k = tpk0
12738  t2k = tppk0
12739  sk = sk0
12740  s1k = spk0
12741  s2k = sppk0
12742  tp3k0 = 0.
12743  tp4k0 = 0.
12744  sp3k0 = 0.
12745  sp4k0 = 0.
12746  ! MULTIPLY TRANSIT TIME factors WITH FAKT
12747  t0 = t0*fakt
12748  tp0 = tp0*fakt
12749  tpp0 = tpp0*fakt
12750  tk0 = -t0
12751  tpk0 = -tp0
12752  spk0 = -ylg*t0/2.
12753  tppk0 = ylg*ylg*t0/4. - tpp0
12754  sppk0 = -ylg*tp0/2.
12755  tk = tk0
12756  t1k = tpk0
12757  t2k = tppk0
12758  sk = sk0
12759  s1k = spk0
12760  s2k = sppk0
12761  ! IPOINR=IPOINR+1
12762  ! print in file: 'short.data'
12763  ! --- ylg : CELL LENGTH (cm) ==> (mm)
12764  ! --- ye0 : ELECTRIC FIELD (MV/cm) ==> (Kv/mm)
12765  ! --- davtot (mm)
12766  idav = idav + 1
12767  iitem(idav) = 17
12768  dav1(idav, 1) = ylg*10.
12769  dav1(idav, 2) = ye0*100.
12770  tstp = (davtot+ylg*xpsc)*10.
12771  davtot = davtot + ylg
12772  dav1(idav, 24) = davtot*10.
12773  ! 21.11.09 dav1(idav,40)=fh
12774  fh0 = fh/vl
12775  ! STATISTICS FOR PLOT
12776  if (iprf==1) call stapl(dav1(idav,24))
12777  ! reference particle
12778  iarg = 1
12779  call cdg(iarg)
12780  ecog = cog(1)
12781  enold = ecog
12782  gcog = ecog/xmat
12783  bcog = sqrt(1.-1./(gcog*gcog))
12784  tcog = cog(3)
12785  if (shift) then
12786  ! reference particle and cog are independent
12787  beref = vref/vl
12788  gamref = 1./sqrt(1.-(beref*beref))
12789  enref = xmat*gamref
12790  trefdg = tref*fh*180./pi
12791  tcogdg = tcog*fh*180./pi
12792  dav1(idav, 3) = 1.
12793  else
12794  ! reference and c.o.g. are coinciding
12795  vref = bcog*vl
12796  tref = tcog
12797  gamref = gcog
12798  beref = bcog
12799  enref = cog(1)
12800  trefdg = tref*fh*180./pi
12801  tcogdg = tcog*fh*180./pi
12802  dav1(idav, 3) = 0.
12803  end if
12804  ! --- ttvol: time of flight at entrance (sec)
12805  ttvol = 0.
12806  if (itvol) ttvol = ttvols*fh
12807  ! ***** reference is placed in the position ngdrf=ngood+1 in array f(10,i)
12808  ! ***** ngdrf=ngood+1
12809  ! ***** BEREF=VREF/VL
12810  ! ***** GAMREF=1./SQRT(1.-(BEREF*BEREF))
12811  ! ***** ENREF=XMAT*GAMREF
12812  ! **** f(1,ngdrf)=ngdrf
12813  ! **** f(2,ngdrf)=0.
12814  ! **** f(3,ngdrf)=0.
12815  ! **** f(4,ngdrf)=0.
12816  ! **** f(5,ngdrf)=0.
12817  ! **** f(6,ngdrf)=tref
12818  ! **** f(7,ngdrf)=enref
12819  ! **** f(8,ngdrf)=1.
12820  ! **** f(9,ngdrf)=qst
12821  ! **** f(10,ngdrf)=0.
12822  if (dav1(idav,3)==1.) write (16, *) ' ****reference and cog are different'
12823  if (dav1(idav,3)==0.) write (16, *) ' **** reference and cog coincide '
12824  write (16, 178)
12825 178 format (/, ' DYNAMICS AT THE INPUT ', /, 5x, ' BETA GAMMA ENERGY(MeV) ', &
12826  ' TOF(deg) TOF(sec)')
12827  write (16, 1788) bcog, gcog, ecog - xmat, tcogdg, tcog
12828 1788 format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
12829  write (16, 165) beref, gamref, enref - xmat, trefdg, tref
12830 165 format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
12831  tofprt = tref
12832  ! iprint=1: full print ( in case of pbmes)
12833  iprint = 0
12834  call statis
12835  xk1 = fh/vref
12836  ! --- predictor of the average beta:BEMY.
12837  beref = vref/vl
12838  gamref = 1./sqrt(1.-(beref*beref))
12839  ! DPHASE : PHASE AT THE MIDDLE OF THE CELL (rad)
12840  dphete = etcell(12)
12841  dphase = etcell(12)*pi/180.
12842  ! 15/12/09 dpherd=dphase
12843  ! 15/12/09 ttvol=0.
12844  ! --- The option TOF is passive in the DTL
12845  ! t.o.f. at the middle of the cell
12846  ! 15/12/09 if(itvol) then
12847  ! 15/12/09 tvolm=ylg/(2.*vref)
12848  ! 15/12/09 ttvol=(ttvols+tvolm)
12849  ! 15/12/09 endif
12850  ! 15/12/09 adjust the phase of RF w.r.t. TOF
12851  ! 15/12/09 if(itvol.and.imamin) then
12852  ! 15/12/09 odphase=dphase
12853  ! 15/12/09 ottvol=fh*ttvol*180./pi
12854  ! 15/12/09 attvol=ottvol
12855  ! 15/12/09 xkpi=ottvol/360.
12856  ! 15/12/09 ixkpi=int(xkpi)
12857  ! 15/12/09 xkpi=(xkpi-float(ixkpi))*360.
12858  ! 15/12/09 dphase=dphase-xkpi*pi/180.
12859  ! 15/12/09 endif
12860  aqst = abs(qst)
12861  ddw = aqst*t0*cos(dphase)
12862  enrefs = enref + ddw
12863  gams = enrefs/xmat
12864  bets = sqrt(1.-1./(gams*gams))
12865  xk2 = fh/(bets*vl)
12866  bemy = (gams*bets+gamref*beref)/(gams+gamref)
12867  xkm = fh/(bemy*vl)
12868  xkg = 2.*pi/ylg
12869  ! --- average phase of RF at entrance
12870  saphi = dphase
12871  sapho = saphi
12872  eqvl = ylg
12873  dkg = (xkm-xkg)
12874  dts = tp0/t0
12875  fk1 = 2.*dts
12876  fpk0 = (tp0*tp0+t0*tpp0)/(t0*t0)
12877  fpk1 = 2.*tp0**2/(t0*t0)
12878  fpk = 2.*(fpk0-fpk1)
12879  pcrest = atan(-sk/tk)
12880  ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))/2.
12881  if (ddw<0.) pcrest = pcrest + pi
12882  peqvl = ylg/2.
12883  sclen = ylg
12884  ! 15/12/09 if(.not.imamin) then
12885  write (16, 1555) fh/(2.*pi), ylg, dphase*180./pi
12886 1555 format (4x, 'FREQENCY :', e12.5, ' Hertz', /, 4x, 'GAP LENGTH :', e12.5, ' cm', /, 4x, &
12887  'PHASE of RF (middle of the gap) :', e12.5, 'deg', /)
12888  ! 15/12/09 else
12889  ! 15/12/09 WRITE(16,1556)FH/(2.*pi),YLG,DPHASE*180./PI,odphase
12890  ! 15/12/09 1556 FORMAT(4X,'FREQENCY :',E12.5,' Hertz',/,4x,
12891  ! 15/12/09 x 'GAP LENGTH :',e12.5,' cm',/,4x,
12892  ! 15/12/09 x 'phase of RF after adjustement:',e12.5,'deg',/,4x,
12893  ! 15/12/09 * 'phase of RF before adjustment',e12.5,'deg')
12894  ! 15/12/09 endif
12895  ! --- Follow ITERATIONS giving:
12896  ! The equivalent field length (cm)
12897  ! The asociated drift length (cm)
12898  ! The slip of phase (rd)
12899  ! The energy gain (MeV)
12900  ! The phase jump (rd)
12901  ! The average k (cm-1)
12902  ! The transit time coefficients (MeV,cm)
12903  ! The phase crest (rad)
12904  ! The phase offset at entrance (rad)
12905  eqvl = ylg
12906  dkg = (xkm-xkg)
12907  fpk = 2.*(fpk0-fpk1)
12908  til2 = 0.
12909  do it = 1, 3
12910  ! slip of phase and equivalent field length
12911  if (it==1) phslip = -4.*atan(3.2*dts/eqvl)
12912  if (phslip/=0.) then
12913  til2 = phslip/2.
12914  do iiii = 1, 4
12915  gx = 1./tan(til2) - 1./til2
12916  gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
12917  gppx = 2.*cos(til2)/(sin(til2)**3) - 2./(til2*til2*til2)
12918  hx = gpx/(gx*gx) - 2.*fpk/(fk1**2)
12919  dhx = -(2.*gx*gpx*gpx-gx*gx*gppx)/(gx**4)
12920  til2 = til2 - hx/dhx
12921  eqvl = sqrt(abs(2.*fpk/gpx))
12922  if (abs(hx)<=1.e-05) go to 556
12923  end do
12924 556 continue
12925  phslip = til2*2.
12926  end if
12927  peqvl = ylg/2.
12928  asdl = peqvl - eqvl/2.
12929  ! ENERGY GAIN AND PHASE JUMP (i.e. DELPHR)
12930  ! saphi=sapho-pcrest+ttvol*fh
12931  saphi = sapho - pcrest + ttvol
12932  ! TESTsv05.05.2011 saphi=sapho-pcrest
12933  f0 = xitl0(gamref, gams, bemy, saphi, aqst)
12934  delwrm = (f0-gamref)*xmat
12935  enrs = enref + delwrm
12936  gams = enrs/xmat
12937  bets = sqrt(1.-1./(gams*gams))
12938  xk2 = fh0/bets
12939  coeph = fh*aqst/(vl*xmat)
12940  f2 = xitl2(gamref, gams, bemy, saphi, aqst)
12941  delphr = coeph*f2
12942  xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
12943  bemy = fh0/xkm
12944  ! TRANSIT TIME FACTORS
12945  dkg = (xkm-xkg)
12946  tk = tk0 + dkg*tpk0 + dkg*dkg*tppk0/2. + dkg**3*tp3k0/6. + dkg**4*tp4k0/24.
12947  t1k = tpk0 + dkg*tppk0 + dkg*dkg*tp3k0/2. + dkg**3*tp4k0/6.
12948  t2k = tppk0 + dkg*tp3k0 + dkg*dkg*tp4k0/2.
12949  t3k = tp3k0 + dkg*tp4k0
12950  t4k = tp4k0
12951  sk = sk0 + dkg*spk0 + dkg*dkg*sppk0/2. + dkg**3*sp3k0/6. + dkg**4*sp4k0/24.
12952  s1k = spk0 + dkg*sppk0 + dkg*dkg*sp3k0/2. + dkg**3*sp4k0/6.
12953  s2k = sppk0 + dkg*sp3k0 + dkg*dkg*sp4k0/2.
12954  s3k = sp3k0 + dkg*sp4k0
12955  s4k = sp4k0
12956  ! PHASE CREST
12957  pcrest = atan(-sk/tk)
12958  ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))/2.
12959  if (ddw<0.) pcrest = pcrest + pi
12960  end do
12961  ! CREST VALUE = SQCTTF*(PHSLIP/2)/SIN(PHSLIP/2)
12962  sqcttf = til2*sqrt(tk*tk+sk*sk)/sin(til2)*2.
12963  ! THE synchronous particle IS BASED ON CHARGE STATE : QMOY =AQST
12964  cfh = fh/(vl*2.*xmat)
12965  ckh = qmoy*qmoy/(4.*xmat*xmat)
12966  call gap(gamref, saphi, gams, delphr)
12967  ! output of the element
12968  ! new PHARES,TREFS to be in accordance with GENAC
12969  phares = saphi + fh*ylg/vref + delphr
12970  trefs = tref + ylg/(bets*vl) + delphr/fh
12971  phared = (phares-saphi)*180./pi
12972  tredg = fh*trefs*180./pi
12973  write (16, *) ' PARAMETERS RELATING TO THE REFERENCE PARTICLE '
12974  write (16, *) '************************************************'
12975  write (16, *) ' ENERGY GAIN(MeV): ', delwrm, ' TOF(DEG) ', tredg
12976  ! write(16,*) ' PHASE JUMP(DEG): ',sphrfs*180./PI
12977  write (16, *) ' CREST PHASE OF RF (DG): ', pcrest*180./pi
12978  write (16, *) ' PHASE OF RF AT THE MIDDLE (DG): ', sapho*180./pi
12979  write (16, *) ' PHASE OF RF AT THE ENTRANCE (DG): ', saphi*180./pi
12980  write (16, *) ' AVERAGE k (cm-1) (freq./velocity): ', xkm
12981  write (16, *) ' TRANSIT TIME FACTORS (MeV-cm):'
12982  write (16, *) ' T dT/dk d2T/dk2 ', tk, t1k, t2k
12983  write (16, *) ' S dS/dk d2S/dk2 ', sk, s1k, s2k
12984  write (16, *) ' PHASE SLIP(DEG) ', phslip*180./pi
12985  write (16, *)
12986  write (16, *) ' PARAMETERS RELATING TO THE EQUIVALENT FIELD '
12987  write (16, *) '************************************************'
12988  write (16, 171) eqvl
12989 171 format (' length :', e12.5, ' cm ')
12990  write (16, *) ' Associated drift length: ', asdl, ' cm'
12991  write (16, *) ' magnitude: ', sqcttf, ' MV/cm'
12992  iarg = 1
12993  call cdg(iarg)
12994  encog = cog(1)
12995  gcog = encog/xmat
12996  bcog = sqrt(1.-1./(gcog*gcog))
12997  tcog = cog(3)
12998  call ext2d(1)
12999  ! sup phnew=-(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
13000  ! sup dav1(idav,7)=phnew
13001  dav1(idav, 37) = saphi*180./pi
13002  ! 15/12/09 if(itvol) then
13003  ! 15/12/09 dav1(idav,38)=dphete
13004  ! 15/12/09 dav1(idav,39)=dphase*180./pi
13005  ! 15/12/09 else
13006  dav1(idav, 38) = dphete
13007  ! 15/12/09 endif
13008  ! end print in the file: 'short.data'
13009  write (16, 3777)
13010 3777 format (/, 3x, 3('*'), ' DYNAMICS AT THE OUTPUT: ', /, 5x, ' BETA dW(MeV) ENERGY(MeV) ', &
13011  ' TOF(deg) TOF(sec)')
13012  write (16, 3473) bets, delwrm, enrs - xmat, fh*trefs*180./pi, trefs
13013 3473 format (' REF ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
13014  write (16, 1789) bcog, encog - enold, encog - xmat, tcog*fh*180./pi, tcog
13015 1789 format (' COG ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
13016  ! trace3d
13017  ! split cell into drif-gap-drift
13018  kt3t = kt3t + 1
13019  write (tif, 6001) kt3t, kt3t, 10.*etcell(4)/2.
13020 6001 format (' nt(', i4, ')= 1, a(1,', i4, ')=', f12.6)
13021  trace3t(kt3t) = tif
13022 
13023  trphase = etcell(12)
13024  ! tre0tl=etcell(11)*etcell(5)*etcell(4)/100.
13025  tre0tl = delwrm/cos(pi*trphase/180.)
13026  kt3t = kt3t + 1
13027  write (tif, 6005) kt3t, kt3t, tre0tl, trphase, fid
13028 6005 format (' nt(', i4, ')=10, a(1,', i4, ')=', f9.5, ' , ', f9.2, ', 1., 1.,', f5.3, ',')
13029  trace3t(kt3t) = tif
13030 
13031  kt3t = kt3t + 1
13032  write (tif, 6001) kt3t, kt3t, 10.*etcell(4)/2.
13033  trace3t(kt3t) = tif
13034  ! end trace3d drift-gap-drift
13035  testca = exten(1)*exten(2)*exten(3)
13036  epsil = 1.e-40
13037  if (abs(testca)>epsil) then
13038  qdisp = 2.*sqrt(exten(1))
13039  qmd = exten(1)*exten(3) - exten(2)**2
13040  sqmdv = 4.*pi*sqrt(qmd)
13041  surm = 4.*pi*sqrt(qmd)*180./pi
13042  qdp = 2.*sqrt(exten(3))
13043  cor12 = exten(2)/sqrt(exten(1)*exten(3))
13044  qdpde = qdp*180./pi
13045  else
13046  qdisp = 0.
13047  qmd = 0.
13048  sqmdv = 0.
13049  surm = 0.
13050  qdp = 0.
13051  cor12 = 0.
13052  pent12 = 0.
13053  pent21 = 0.
13054  qdpde = 0.
13055  end if
13056  trqtx = exten(4)*exten(5) - exten(8)**2
13057  trqpy = exten(6)*exten(7) - exten(9)**2
13058  qditax = 2.*sqrt(exten(4))
13059  qdiant = 2.*sqrt(exten(5))
13060  qditay = 2.*sqrt(exten(6))
13061  qdianp = 2.*sqrt(exten(7))
13062  surxth = 4.*pi*sqrt(trqtx)
13063  suryph = 4.*pi*sqrt(trqpy)
13064  if (shift) then
13065  vref = bets*vl
13066  tref = trefs
13067  else
13068  vref = bcog*vl
13069  tref = tcog
13070  end if
13071  if (itvol) then
13072  ttvols = tref
13073  ! 15/12/09 attvol=fh*ttvols*180./pi
13074  ! 15/12/09 write(16,7456) ottvol,attvol
13075  end if
13076  ! 15/12/09 7456 format(2x,'***tof at input: ',e12.5,' deg',/,
13077  ! 15/12/09 * 2x,'***tof at output: ',e12.5,' deg')
13078  call statis
13079  ! PROFIL (plot)
13080  call stapl(dav1(idav,24))
13081  dltaw = qdisp*xmat*bcog*bcog/sqrt(1.-bcog*bcog)
13082  ! sup WRITE(16,9998) SQMDV
13083  ! sup9998 FORMAT(2X,' EMITTANCE (norm): ',
13084  ! sup * E12.5,' PI*MEV*RAD')
13085  ! print in the file: 'dynac.dmp':
13086  ! gap number, phase offset(deg), relativistic beta, energy(MeV), horz. emit.(mm*mrd,norm), vert.
13087  ! emit.(mm*mrd,norm),long. emit(keV*sec)
13088  ! dav1(idav,16): Emittance(norm) x-xp (mm*mrad)
13089  dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
13090  ! dav1(idav,21): Emittance(norm) y-yp (mm*mrad)
13091  dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
13092  dav1(idav, 25) = ndtl
13093  emns = 1.e12*sqmdv/(pi*fh)
13094  ! et2010s
13095  trfprt = fh*tref*180./pi
13096  tcgprt = fh*tcog*180./pi
13097  ! n2kp=int(tofprt/360.)
13098  ! tofprt=tofprt-float(n2kp)*360.
13099  ! if(tofprt.gt.180.) tofprt=tofprt-360.
13100  ! cavity number, z(m), transmission (%), synchronous phase (deg), time of flight (deg) (cog), COG relativistic
13101  ! beta (@ output)
13102  ! COG output energy (MeV), time of flight (deg) (REF), REF relativistic beta (@ output), REF output energy (MeV),
13103  ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
13104  ! longitudinal emittance (RMS, ns.keV)
13105  trnsms = 100.*float(ngood)/float(imax)
13106  if (ndtl==1) write (50, *) '# gap.dmp'
13107  if (ndtl==1) write (50, *) '# gap Z trans ', &
13108  'PHIs TOF(COG) COG Wcog TOF(REF) ', &
13109  ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS'
13110  if (ndtl==1) write (50, *) '# # (m) (%) ', &
13111  '(deg) (deg) beta (MeV) (deg) ', &
13112  ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)'
13113  write (50, 7023) ndtl, 0.01*davtot, trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, enrs - xmat, &
13114  0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
13115 7023 format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
13116  ! et2010e
13117  ! RIGIDITY of the ref. prtcle
13118  gref = 1./sqrt(1.-bets*bets)
13119  xmor = xmat*bets*gref
13120  boro = 33.356*xmor*1.e-01/qst
13121  write (16, *) ilost, ' particles are lost in element ', ndtl
13122  write (16, *)
13123  call emiprt(0)
13124  return
13125  end subroutine etgap
13126  ! *******************************************************************
13127  ! SUBROUTINE gap(GAMREF,SAPHI,GAMS,DELPHR)
13128  ! ETGAP or RESTAY ==> GAP
13129  ! dynamics in the accelerating element
13130  ! *******************************************************************
13131  subroutine gap(gamref, saphi, gams, delphr)
13132  implicit real *8(a-h, o-z)
13133  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
13134  common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
13135  fhpar, nc
13136  common /posi/ist
13137  common /midgap/enmil, vapmi
13138  common /azmtch/dlg, xmcph, xmce
13139  common /azlist/icont, iprin
13140  common /itvole/itvol, imamin
13141  common /func/a(200), ylg, atte, ncel, nharm
13142  ! TRANSIT TIME COEFFICIENTS
13143  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
13144  ! ***************************************************************
13145  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
13146  common /jacob/gaks, gaps
13147  common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
13148  xk1ii, xk2ii
13149  ! functions in COS(DXDPT)
13150  common /iterco/yh11t, yh1k1t, yh1k01t, yh10pkt, yh11pkt, yh1p1t, h1akit, h1akimt, h1akmt, hapit, happit
13151  ! functions in SIN(DXDPT)
13152  common /itersi/yh21t, yh2k1t, yh2k01t, yh2p1t, yh20pkt, yh21pkt, h1bkit, h1bkimt, h1bkmt, hbpit, hbppit
13153  common /tranrs/sa11, sa12, sa21, sa22, sact11, sact12, sact21, sact22
13154  ! --- routine XTYPL1
13155  common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
13156  common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
13157  common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
13158  common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
13159  common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
13160  ! --- routine XTYPLP1
13161  common /typlp1/yh1p1, yh2p1, hapi, hbpi
13162  ! --- routine XTYPL2
13163  common /typlp2/happi, hbppi
13164  ! --- routine XTYLPK
13165  common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
13166  ! Integrals of E(z)**2
13167  ! --- routine XTYPJ
13168  common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
13169  yfscp1, yfscp2, yfs0, yfs1, yfs2
13170  ! --- routine XTYPM
13171  common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
13172  ! ********************************************************************
13173  common /faisc/f(10, iptsz), imax, ngood
13174  common /qmoyen/qmoy
13175  common /rigid/boro
13176  common /beamsa/fs(7, iptsz)
13177  common /cdek/dwp(iptsz)
13178  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
13179  common /consta/vl, pi, xmat, rpel, qst
13180  common /dyn/tref, vref
13181  common /tapes/in, ifile, meta
13182  common /etcom/cog(8), exten(17), fd(iptsz)
13183  common /speda/dave, idave
13184  common /shif/dtiph, shift
13185  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
13186  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
13187  common /dcspa/iesp
13188  common /fene/wdisp, wphas, wx, wy, rlim, ifw
13189  common /appel/irstay, ilost, iavp, ispcel
13190  common /posc/xpsc
13191  common /pstpla/tstp
13192  common /rander/ialin
13193  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
13194  logical iesp, ichaes, irstay, iavp, ispcel, ialin
13195  logical shift, chasit, itvol, imamin, dave
13196  ! ***** DWRFS(MeV): gain of energy of the fictitious reference
13197  ! ***** SPHRFS(rad): phase jump
13198  ! ***** PHRFS(rad): phase
13199  ! ***** NGDRF: position of the reference in the array f(10,iptsz)
13200  ! **** common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
13201  ! CHARACTER*1 CHOPT
13202  fh0 = fh/vl
13203  ! iesp is used in s.c. routines : iesp=.false. == > accel. element
13204  iesp = .false.
13205  iavp = .true.
13206  ipas = 2
13207  dcum = ylg
13208  ! random errors in alignment
13209  if (ialin) call randali
13210  ! Random variation on the phase for each particle
13211  varpha = 0.
13212  ! INTEGRALS REQUIRED BY THE EXPANSIONS IN LONGITUDINAL MOTION (ALL THE ELEMENT)
13213  ! ( computations of the average k and slip of phase from which are computed deltk delphi,..)
13214  ! * valero 08/08/07
13215  aqmoy = abs(qst)
13216  ! omment aqmoy=qst
13217  ! *
13218  call xtypl1(gamref, saphi, aqmoy, dcum)
13219  ! see here equations 88 and 106 of Part. Acc. 1994 vol44 pp215-255
13220  cxlg = aqmoy/(4.*xmat*eqvl)
13221  gami = gamref
13222  dkmp = (gami*gami-1.)**(1.5)*(gams*gams-1.)**(-1.5)
13223  dkms = dkmp*(1.+asdl/eqvl) + yh1k01*fh0*cxlg/eqvl - asdl/eqvl
13224  dkm1 = -gaks*(gams*gams-1.)**(-1.5)*fh0*(1.+asdl/eqvl)
13225  ! DKMSKE :(eq.106, see article of Part.Acc.)
13226  dkmske = dkms/(1.-yh1k1*cxlg*fh0/eqvl-dkm1)
13227  call xtypl2(gamref, saphi, aqmoy, dcum)
13228  call xtyplp1(gamref, saphi, aqmoy, dcum)
13229  call xtylpk(gamref, saphi, aqmoy, dcum)
13230  dphsph1 = (yh1p1-yh21)*cxlg*fh0
13231  dkmsphi = -fh0*(gams*gams-1.)**(-1.5)*gaps*(1.+asdl/eqvl) + dphsph1/eqvl
13232  ! These integrals are saved
13233  gakst = gaks
13234  gapst = gaps
13235  ! functions in COS(DXDPT)
13236  yh11t = yh11
13237  yh1k1t = yh1k1
13238  yh1k01t = yh1k01
13239  yh10pkt = yh10pk
13240  yh11pkt = yh11pk
13241  yh1p1t = yh1p1
13242  h1akit = h1aki
13243  h1akimt = h1akim
13244  h1akmt = h1akm
13245  hapit = hapi
13246  happit = happi
13247  ! functions in SIN(DXDPT)
13248  yh21t = yh21
13249  yh2k1t = yh2k1
13250  yh2k01t = yh2k01
13251  yh2p1t = yh2p1
13252  yh20pkt = yh20pk
13253  yh21pkt = yh21pk
13254  h1bkit = h1bki
13255  h1bkimt = h1bkim
13256  h1bkmt = h1bkm
13257  hbpit = hbpi
13258  hbppit = hbppi
13259  if (ichaes .and. ispcel) then
13260  ipas = 1
13261  write (16, *) ' SPACE CHARGE ACTING ON LENGTH: ', scdist, ' CM'
13262  dcum = ylg*xpsc
13263  write (16, *) ' POSITION OF S.C. COMPUTATION: ', dcum, ' CM'
13264  ! computation of the integrals in the middle of the cavity
13265  ! INTEGRALS E(z)*(BG)**-3 *z**n n=0,1
13266  ! INTEGRALS dE(z)/dt*(BG)**-3 *z**n n=0,1,2
13267  call xtypl1(gamref, saphi, aqmoy, dcum)
13268  istm = ist - 1
13269  ! INTEGRALS ON SECOND DERIVATIVES k HA0(Z) & HB0(Z)
13270  call xtypl2(gamref, saphi, aqmoy, dcum)
13271  ! 1st,2nd,3rd DERIVATIVES ON PHASE,HA0(Z) & HB0(Z)
13272  call xtyplp1(gamref, saphi, aqmoy, dcum)
13273  ! DERIVATIVES COUPLED ON PHASE, K FUNCTIONS HA0(Z) & HB0(Z)
13274  call xtylpk(gamref, saphi, aqmoy, dcum)
13275  ! TRANSVERSE INTEGRALS TYPE J & M
13276  call xtypj(gamref, saphi, aqmoy, dcum)
13277  call xtypm(gamref, saphi, aqmoy, dcum)
13278  end if
13279 1026 continue
13280  if (ipas==2) then
13281  dcum = ylg
13282  gaks = gakst
13283  gaps = gapst
13284  ! --- COS(DXDPT)
13285  yh11 = yh11t
13286  yh1k1 = yh1k1t
13287  yh1k01 = yh1k01t
13288  yh10pk = yh10pkt
13289  yh11pk = yh11pkt
13290  yh1p1 = yh1p1t
13291  h1aki = h1akit
13292  h1akim = h1akimt
13293  h1akm = h1akmt
13294  hapi = hapit
13295  happi = happit
13296  ! --- SIN(DXDPT)
13297  yh21 = yh21t
13298  yh2k1 = yh2k1t
13299  yh2k01 = yh2k01t
13300  yh2p1 = yh2p1t
13301  yh20pk = yh20pkt
13302  yh21pk = yh21pkt
13303  h1bki = h1bkit
13304  h1bkim = h1bkimt
13305  h1bkm = h1bkmt
13306  hbpi = hbpit
13307  hbppi = hbppit
13308  call xtypl1(gamref, saphi, aqmoy, dcum)
13309  ! INTEGRALS ON SECOND DERIVATIVES k HA0(Z) & HB0(Z)
13310  call xtypl2(gamref, saphi, aqmoy, dcum)
13311  ! 1st,2nd,3rd DERIVATIVES ON PHASE,HA0(Z) & HB0(Z)
13312  call xtyplp1(gamref, saphi, aqmoy, dcum)
13313  ! DERIVATIVES COUPLED ON PHASE, K FUNCTIONS HA0(Z) & HB0(Z)
13314  call xtylpk(gamref, saphi, aqmoy, dcum)
13315  ! TRANSVERSE INTEGRALS TYPE J & M
13316  call xtypj(gamref, saphi, aqmoy, dcum)
13317  call xtypm(gamref, saphi, aqmoy, dcum)
13318  end if
13319  sa11 = 1.
13320  sa12 = 0.
13321  sa21 = 0.
13322  sa22 = 1.
13323  sact11 = 1.
13324  sact12 = 0.
13325  sact21 = 0.
13326  sact22 = 1.
13327  ! SAVE BEAM
13328  do is = 1, ngood
13329  do js = 1, 7
13330  fs(js, is) = f(js, is)
13331  end do
13332  end do
13333  ! 1055 CONTINUE
13334  call boucle(ipas, gamref, saphi, dcum, delphr)
13335  ! Reshuffles f(i,j) array after boucle
13336  call shuffle
13337  if (ipas==1) then
13338  ! compute the space charge on the beam (except the reference)
13339  ! call stapl at the position of space charge computation
13340  ! *et*26-Jul-2014 call stapl(tstp)
13341  if (iscsp==1) then
13342  ini = 1
13343  call hersc(ini)
13344  ini = 2
13345  call hersc(ini)
13346  end if
13347  if (iscsp==2) call schermi
13348  if (iscsp==3) call scheff1(1)
13349  ! ----- window control
13350  write (16, *) 'Checking for lost particles'
13351  call reject(ilost)
13352  ! Reshuffles f(i,j) array after window (now done in 'reject')
13353  ! call shuffle
13354  ! second step of the gap
13355  ipas = 2
13356  iavp = .false.
13357  go to 1026
13358  ! end of space charge computation
13359  end if
13360  ! charateristics of the beam
13361  ! 18/03/2009 if (dave) then
13362  ! 18/03/2009 gimax=f(7,ngood)/xmat
13363  ! 18/03/2009 bimax=sqrt(1.-1./(gimax*gimax))
13364  ! 18/03/2009 dav1(idav,3)=bimax
13365  ! 18/03/2009 dav1(idav,4)=f(7,ngood)-xmat
13366  ! 18/03/2009 dav1(idav,5)=-(INT(f(6,ngood)*FH/PI+0.5)-
13367  ! 18/03/2009 * f(6,ngood)*FH/PI)*180.
13368  ! 18/03/2009 dav1(idav,38)=dphase*180./pi
13369  ! 18/03/2009 endif
13370  ! ---- WINDOW CONTROL
13371  call reject(ilost)
13372  ! Reshuffles f(i,j) array after window (now done in 'reject')
13373  ! call shuffle
13374  return
13375  end subroutine gap
13376  ! *******************************************************************
13377  ! SUBROUTINE cogetc
13378  ! COG of TOF with respect to the various charge states
13379  ! *******************************************************************
13380  subroutine cogetc
13381  implicit real *8(a-h, o-z)
13382  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
13383  common /faisc/f(10, iptsz), imax, ngood
13384  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
13385 
13386  itot = 0
13387  n = 1
13388  do i = 1, 20
13389  nbch(i) = 0
13390  end do
13391  charm(n) = f(9, 1)
13392 100 continue
13393  do i = 1, ngood
13394  if (f(9,i)==charm(n)) nbch(n) = nbch(n) + 1
13395  end do
13396  ! the following charge states
13397  itot = itot + nbch(n)
13398  if (itot>=ngood) go to 110
13399  do i = 1, ngood
13400  do j = 1, n
13401  if (f(9,i)==charm(j)) go to 120
13402  end do
13403  if (f(9,i)/=charm(n)) then
13404  n = n + 1
13405  charm(n) = f(9, i)
13406  go to 100
13407  end if
13408 120 continue
13409  end do
13410 110 continue
13411  ! compute the cog of TOF for each charge state
13412  do i = 1, n
13413  cgtdv(i) = 0.
13414  do j = 1, ngood
13415  if (f(9,j)==charm(i)) cgtdv(i) = cgtdv(i) + f(6, j)
13416  end do
13417  cgtdv(i) = cgtdv(i)/float(nbch(i))
13418  ! write(16,*)'i,nch,cgtdv=',i,nbch(i),cgtdv(i),charm(i)
13419  end do
13420  netac = n
13421  return
13422  end subroutine cogetc
13423  ! *******************************************************************
13424  ! SUBROUTINE boucle(ipas,gamref,saphi,dcum,delphr)
13425  ! RESTAY or ETGAP ==> GAP ==> BOUCLE
13426  ! compute the dynamics of the fictitiuos reference and of particles
13427  ! *******************************************************************
13428  subroutine boucle(ipas, gamref, saphi, dcum, delphr)
13429  implicit real *8(a-h, o-z)
13430  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
13431  common /posi/ist
13432  common /midgap/enmil, vapmi
13433  common /azmtch/dlg, xmcph, xmce
13434  common /azlist/icont, iprin
13435  common /itvole/itvol, imamin
13436  common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
13437  xk1ii, xk2ii
13438  common /tranrs/sa11, sa12, sa21, sa22, sact11, sact12, sact21, sact22
13439  common /func/a(200), ylg, atte, ncel, nharm
13440  common /blvl/bflvl
13441  ! TRANSIT TIME COEFFICIENTS
13442  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
13443  common /ttfcb/t3k, t4k, s3k, s4k
13444  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
13445  common /jacob/gaks, gaps
13446  common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
13447  common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
13448  common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
13449  common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
13450  common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
13451  ! --- routine XTYPLP1
13452  common /typlp1/yh1p1, yh2p1, hapi, hbpi
13453  ! --- routine XTYPL2
13454  common /typlp2/happi, hbppi
13455  ! --- routine XTYLPK
13456  common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
13457  ! integrals of E(z)**2
13458  ! --- routine XTYPJ
13459  common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
13460  yfscp1, yfscp2, yfs0, yfs1, yfs2
13461  ! E(z)**2 INTEGRALS (COMPLEMENTARY ELECTRIC FIELD)
13462  ! --- routine XTYPM
13463  common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
13464  common /faisc/f(10, iptsz), imax, ngood
13465  common /beamsa/fs(7, iptsz)
13466  common /cdek/dwp(iptsz)
13467  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
13468  common /consta/vl, pi, xmat, rpel, qst
13469  common /dyn/tref, vref
13470  common /fene/wdisp, wphas, wx, wy, rlim, ifw
13471  common /tapes/in, ifile, meta
13472  common /dcspa/iesp
13473  common /tcav/sv1p(iptsz), sv2p(iptsz), sxv1p(iptsz), sxv2p(iptsz), dwcis(iptsz), beini1(iptsz), phip(iptsz), &
13474  teglp(iptsz), dxdpip(iptsz), dxdkip(iptsz), dxdptp(iptsz), dxk00p(iptsz), dphiip(iptsz), sauphcs(iptsz)
13475  common /iterco/yh11t, yh1k1t, yh1k01t, yh10pkt, yh11pkt, yh1p1t, h1akit, h1akimt, h1akmt, hapit, happit
13476  common /itersi/yh21t, yh2k1t, yh2k01t, yh2p1t, yh20pkt, yh21pkt, h1bkit, h1bkimt, h1bkmt, hbpit, hbppit
13477  common /appel/irstay, ilost, iavp, ispcel
13478  common /etcom/cog(8), exten(17), fd(iptsz)
13479  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
13480  common /tofev/ttvols
13481  common /aerp/vphase, vfield, ierpf
13482  ! ***** DWRFS(MeV): gain of energy of the fictitious reference
13483  ! ***** SPHRFS(rad):phase jump
13484  ! ***** PHRFS(rad):phase
13485  ! ***** NGDRF: position of the reference in the array f(10,iptsz)
13486  ! ***** common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
13487  logical itvol, imamin, ispcel
13488  logical iesp, iavp, ichaes, irstay
13489  dimension vecx(1)
13490  ! CHARACTER*1 CHOPT
13491  ttvol = ttvols*fh
13492  fh0 = fh/vl
13493  beref = sqrt(1.-1./(gamref*gamref))
13494  call cogetc
13495  tcog = 0.
13496  gcog = 0.
13497  do i = 1, ngood
13498  gcog = gcog + f(7, i)/xmat
13499  tcog = tcog + f(6, i)
13500  end do
13501  tcog = tcog/float(ngood)
13502  gcog = gcog/float(ngood)
13503  bcog = sqrt(1.-1./(gcog*gcog))
13504  wcg = (gcog-1.)*xmat
13505  ! ----- convert wdisp in dp/p (window control)
13506  ! ---- ifw = 0 ===> wdisp = dW/W
13507  ! ---- ifw = 1 ===> wdisp = dW (MeV)
13508  ! ----- convert wdisp in dp/p
13509  if (ifw==0) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
13510  if (ifw==1) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcg)
13511  do i = 1, ngood
13512  if (i==icont) then
13513  write (16, *) '******************************************'
13514  write (16, *) '*** FOLLOWED PARTICLE NUMBER: ', i
13515  if (ipas==1) write (16, *) ' AT SPACE CHARGE POSITION'
13516  if (ipas==2) write (16, *) ' AT OUTPUT '
13517  write (16, *) '******************************************'
13518  end if
13519  if (iavp) then
13520  gini = f(7, i)/xmat
13521  beini = sqrt(1.-1./(gini*gini))
13522  fd(i) = (gini*beini)/(gcog*bcog)
13523  f6i = 0.
13524  do istc = 1, netac
13525  if (f(9,i)==charm(istc)) f6i = f(6, i) - cgtdv(istc)
13526  end do
13527  ! LONGITUDINAL WINDOW CONTROL
13528  if (fh*abs(f6i)>=wphas) f(8, i) = 0.
13529  if (abs(fd(i)-1.)>=dispr) f(8, i) = 0.
13530  ! TRANSVERSE WINDOW CONTROL
13531  radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
13532  if (radiu>=rlim) f(8, i) = 0.
13533  if (abs(f(2,i))>wx) f(8, i) = 0.
13534  if (abs(f(4,i))>wy) f(8, i) = 0.
13535  if (f(8,i)==0) then
13536  write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, &
13537  int(f(9,i))
13538 3928 format (' # ', i5, 1x, i5, 1x, 6(f10.2,1x), 1x, i2)
13539  ilost = ilost + 1
13540  if (ilost>=ngood) stop
13541  go to 19
13542  end if
13543  ! COMPUTATION OF AVERAGE K AND JUMP OF PHASE FOR THE CELL
13544  ! START IF BLOCK on ICONT
13545  if (i==icont) then
13546  write (16, 558) f(2, i), f(3, i), f(4, i), f(5, i)
13547 558 format (1x, '* INPUT OF THE ELEMENT: ', /, 1x, '* X :', e12.5, ' CM XP :', e12.5, ' MRD', /, 1x, '* Y :', &
13548  e12.5, ' CM YP: ', e12.5, ' MRD', /, 1x, '*')
13549  f6dg = fh*f(6, i)*180./pi
13550  write (16, *) ' Tof(deg): ', f6dg, ' ENER(MeV) ', f(7, i) - xmat
13551  end if
13552  radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
13553  if (radiu<1.e-06) then
13554  dradiu = .001*sqrt(f(3,i)*f(3,i)+f(5,i)*f(5,i))
13555  else
13556  dradiu = f(3, i)*.001*f(2, i)/radiu + f(4, i)*f(5, i)*.001/radiu
13557  end if
13558  ! 335 CONTINUE
13559  ! --- retph: phase delay between the actual particle and the reference
13560  retph = fh*(f(6,i)-tref)
13561  ! --- systematic or random defaults on the phase RF (not for the reference)
13562  if (ierpf/=0) then
13563  vphasi = vphase*pi/180.
13564  ! --- systematic default on the phase offset
13565  if (ierpf==1) retph = retph + vphasi
13566  ! --- random error on phase offset
13567  if (ierpf>1) then
13568  len = 1
13569  call rlux(vecx, len)
13570  r1 = (2.*vecx(1)-1.)*vphasi
13571  retph = retph + r1
13572  end if
13573  end if
13574  phi = saphi + retph
13575  if (i==icont) write (16, *) '* PHASE DELAY RELATIVE TO REFERENCE ', retph*180./pi, ' DEG'
13576  ! --- the TTF are the ones of the reference particle based on the charge state qst (input)
13577  ! --- They are corrected in order to take into account the charge state of the current particle
13578  ! **** cort=-(1.-(qst/f(9,i)))
13579  cort = 0.
13580  tkc = tk*cort + tk
13581  t1kc = t1k*cort + t1k
13582  t2kc = t2k*cort + t2k
13583  t3kc = t3k*cort + t3k
13584  t4kc = t4k*cort + t4k
13585  skc = sk*cort + sk
13586  s1kc = s1k*cort + s1k
13587  s2kc = s2k*cort + s2k
13588  s3kc = s3k*cort + s3k
13589  s4kc = s4k*cort + s4k
13590  ! cort1=qst/f(9,i)
13591  cort1 = 1.
13592  ! ************************************
13593  ! Predictor
13594  phase = phi
13595  ! DXKI0 : difference of energy betwen the reference and the actual particle
13596  dxki0 = fh0*(1./beini-1./beref)
13597  dxdte = dxki0
13598  tke = tkc + dxdte*t1kc + dxdte*dxdte*t2kc/2. + dxdte**3*t3kc/6. + dxdte**4*t4kc/24.
13599  ske = skc + dxdte*s1kc + dxdte*dxdte*s2kc/2. + dxdte**3*s3kc/6. + dxdte**4*s4kc/24.
13600  ! TEST*******
13601  ! cc TKE=TKC
13602  ! cc SKE=SKC
13603  ! ******************************************
13604  ! --- systematic or random defaults on the field level (not for the reference)
13605  if (ierpf/=0) then
13606  if (ierpf==1) then
13607  tke = tke*(1.+vfield)
13608  ske = ske*(1.+vfield)
13609  end if
13610  if (ierpf>1) then
13611  len = 1
13612  call rlux(vecx, len)
13613  r1 = (2.*vecx(1)-1.)*vfield
13614  tke = tke*(1.+r1)
13615  ske = ske*(1.+r1)
13616  end if
13617  end if
13618  phiwc = phi + pavph
13619  ! TEST***********
13620  ! ccc PHIWC=PHI
13621  ! *****************************************************
13622  ddwp = abs(f(9,i))*(tke*cos(phiwc)-ske*sin(phiwc))
13623  enpmt = f(7, i) + ddwp
13624  gamps = enpmt/xmat
13625  if (gamps<=1.) f(8, i) = 0.
13626  if (f(8,i)==0.) then
13627  ilost = ilost + 1
13628  if (ilost>=ngood) stop
13629  go to 19
13630  end if
13631  betps = sqrt(1.-1./(gamps*gamps))
13632  xk1ii = fh0/beini
13633  xk2ii = fh0/betps
13634  xkmi = xk2ii + (xk2ii-xk1ii)*asdl/eqvl + delphr/eqvl
13635  xk1i = xk1ii - xkmi
13636  xk2i = xk2ii - xkmi
13637  bempy = fh0/xkmi
13638  sauphc = delphr
13639  dxdki = xkmi - xkm
13640  dphii = (xk1ii-xk2ii)*eqvl/10. + (xkp1+xkp2)/120.*eqvl**2 + xk1i*asdl
13641  do ijk = 1, 3
13642  ! --- boucle IJK to improve TTF
13643  tke = tkc + dxdki*t1kc + dxdki*dxdki*t2kc/2. + dxdki**3*t3kc/6. + dxdki**4*t4kc/24.
13644  t1ke = t1kc + dxdki*t2kc + dxdki*dxdki*t3kc/2. + dxdki**3*t4kc/6.
13645  ske = skc + dxdki*s1kc + dxdki*dxdki*s2kc/2. + dxdki**3*s3kc/6. + dxdki**4*s4kc/24.
13646  s1ke = s1kc + dxdki*s2kc + dxdki*dxdki*s3kc/2. + dxdki**3*s4kc/6.
13647  ! TEST*********
13648  ! cc TKE=TKC
13649  ! cc T1KE=T1KC
13650  ! cc SKE=SKC
13651  ! cc S1KE=S1KC
13652  ! **********************************************************
13653  ! --- systematic or random defaults on the field level (not for the reference)
13654  if (ierpf==1) then
13655  tke = tke*(1.+vfield)
13656  ske = ske*(1.+vfield)
13657  t1ke = t1ke*(1.+vfield)
13658  s1ke = s1ke*(1.+vfield)
13659  end if
13660  if (ierpf>1) then
13661  len = 1
13662  call rlux(vecx, len)
13663  r1 = (2.*vecx(1)-1.)*vfield
13664  tke = tke*(1.+r1)
13665  ske = ske*(1.+r1)
13666  t1ke = t1ke*(1.+r1)
13667  s1ke = s1ke*(1.+r1)
13668  end if
13669  pcresi = 0.
13670  dphci0 = 0.
13671  ! if(f(9,i).ne.qst) then
13672  ! --- new crest phase is PCRESI
13673  ! cc PCRESI=ATAN(-SKE/TKE)
13674  ! cc DDWC=abs(f(9,i))*(TKE*COS(PCRESI)-SKE*SIN(PCRESI))
13675  ! cc IF(DDWC.LT.0.) PCRESI=PCRESI+PI
13676  ! --- DPHCI0 is the difference between the previous crest phase and the present one
13677  ! cc DPHCI0=PCREST-PCRESI
13678  ! endif
13679  ! **************************************
13680  ! cc PHIWC=PHI+DPHII-DPHCI0
13681  ! TEST********
13682  phiwc = phi + dphii
13683  ! ***********************************
13684  ! **** PHIWC=PHI+DPHII
13685  dwci = abs(f(9,i))*(tke*cos(phiwc)-ske*sin(phiwc))
13686  enrc = f(7, i) + dwci
13687  gacr = enrc/xmat
13688  becr = sqrt(1.-1./(gacr*gacr))
13689  xk2ii = fh0/becr
13690  cxlg = abs(f(9,i))/(4.*xmat*eqvl)
13691  dxdpi = retph - dphci0
13692  ! --- see Part. Acc., 1994, vol 44., pp. 215-255
13693  ! ---- relation 86
13694  dxdpt = dxdpi + dxk00*(1.-dkmske)*asdl - dxdpi*dkmsphi*asdl
13695  dxk00 = fh0*(1./beini-1./beref)
13696  xlh11 = (yh11t+dxk00*(dkmske*yh1k1t+yh1k01t))*cos(dxdpt)
13697  xlh11 = xlh11 + dxdpi*yh1p1t*cos(dxdpt)
13698  ! second derivative of Ha0(Z) (division by 2 has been made)
13699  xlh112 = dxk00*dxk00*(h1akit+h1akimt*dkmske+h1akmt*dkmske*dkmske)*cos(dxdpt)
13700  xlh112 = xlh112 + dxdpi*dxdpi*hapit*cos(dxdpt)
13701  xlh112 = xlh112 + dxdpi*dxk00*(yh10pkt+dkmske*yh11pkt)*cos(dxdpt)
13702  ! third derivative of Ha0(Z)
13703  xlh113 = (dxdpi**3)/3.*happit*cos(dxdpt)
13704  xlh11 = xlh11 + xlh112 + xlh113
13705  ! first derivative of Hb0(Z)
13706  xlh21 = (yh21t+dxk00*(dkmske*yh2k1t+yh2k01t))*sin(dxdpt)
13707  xlh21 = xlh21 + dxdpi*yh2p1t*sin(dxdpt)
13708  ! second derivative of Hb0(Z) (division by 2 has been made)
13709  xlh212 = dxk00*dxk00*(h1bkit+h1bkimt*dkmske+h1bkmt*dkmske**2)*sin(dxdpt)
13710  xlh212 = xlh212 + dxdpi*dxdpi*hbpit*sin(dxdpt)
13711  xlh212 = xlh212 + dxdpi*dxk00*(yh20pkt+dkmske*yh21pkt)*sin(dxdpt)
13712  ! third derivative of of Hb0(Z)
13713  xlh213 = (dxdpi**3)/3.*hbppit*sin(dxdpt)
13714  xlh21 = xlh21 + xlh212 + xlh213
13715  xlh1i = cxlg*(xlh11-xlh21)
13716  ! --- SAUPHC is the jump of phase
13717  sauphc = fh0*xlh1i
13718  ! --- XKMI: AVERAGE factor k (k = frequency/velovity)
13719  xkmi = xk2ii + sauphc/eqvl + (xk2ii-xk1ii)*asdl/eqvl
13720  bempy = fh0/xkmi
13721  xk1i = xk1ii - xkmi
13722  dxdki = xkmi - xkm
13723  dphii = (xk1ii-xk2ii)*eqvl/10. + (xkp1+xkp2)/120.*eqvl**2 + xk1i*asdl
13724  end do
13725  ! TEST**** ENDDO IJK=1,3
13726  ! Compute the shift of phase: PHSLIL
13727  dts = (tke*t1ke+ske*s1ke)/(tke*tke+ske*ske)
13728  tiltal = -4.*atan(dts*3.2/eqvl)
13729  if (tiltal/=0.) then
13730  til2 = tiltal/2.
13731  xlrei = eqvl
13732  do iiii = 1, 4
13733  ftil = 1./tan(til2) - 1./til2 - dts*2./xlrei
13734  dftil = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
13735  if (dftil/=6.*0.) then
13736  til2 = til2 - ftil/dftil
13737  gx = 1./tan(til2) - 1./til2
13738  xlrei = 2.*dts/gx
13739  end if
13740  end do
13741  tiltal = til2*2.
13742  end if
13743  phslil = tiltal
13744  tegl1 = phslil*phslil/(sin(phslil/2.)*sin(phslil/2.))
13745  tegl2 = (tke*tke+ske*ske)
13746  tegl = tegl1*tegl2/(eqvl*32.)
13747  tegl = tegl/eqvl
13748  ! --- Transverse motion (field E(z)**2)
13749  phitti = phiwc + xk1i*asdl - phslip/2.
13750  phitsi = phiwc + xk2i*asdl + phslip/2.
13751  cetf1 = f(9, i)*f(9, i)/(16.*xmat*xmat*eqvl*eqvl)
13752  ! TESTsv ***************************
13753  ! OLD**** CETF1=CETF1*cort1*cort1
13754  ! **************************
13755  cfv1 = (gini*gini+2.)/((gini*gini-1.)**2)
13756  cfv2 = (gacr*gacr+2.)/((gacr*gacr-1.)**2)
13757  sv1 = cfv1*(tke*cos(phitti)-ske*sin(phitti))**2
13758  sv1 = cetf1*sv1*(phslil/sin(phslil/2.))**2
13759  sv2 = cfv2*(tke*cos(phitsi)-ske*sin(phitsi))**2
13760  sv2 = cetf1*sv2*(phslil/sin(phslil/2.))**2
13761  ! Transverse motion (field dE(z)/dt)
13762  ceti = fh0*abs(f(9,i))/(4.*xmat*eqvl)
13763  ! TESTsv ***************************
13764  ! OLD**** CETI=CETI*cort1
13765  ! **************************
13766  cxv1 = (gini*gini-1.)**1.5
13767  cxv2 = (gacr*gacr-1.)**1.5
13768  sxv1 = (tke*sin(phitti)+ske*cos(phitti))*phslil/sin(phslil/2.)
13769  sxv1 = -ceti*sxv1/cxv1
13770  sxv2 = (tke*sin(phitsi)+ske*cos(phitsi))*phslil/sin(phslil/2.)
13771  sxv2 = -ceti*sxv2/cxv2
13772  ! --- save all parameters
13773  sv1p(i) = sv1
13774  sv2p(i) = sv2
13775  sxv1p(i) = sxv1
13776  sxv2p(i) = sxv2
13777  dwcis(i) = dwci
13778  sauphcs(i) = sauphc
13779  beini1(i) = beini
13780  phip(i) = phi
13781  teglp(i) = tegl
13782  dxdpip(i) = dxdpi
13783  dxdkip(i) = dxdki
13784  dxdptp(i) = dxdpt
13785  dxk00p(i) = dxk00
13786  dphiip(i) = dphii
13787  ! END IF BLOCK on APV
13788  end if
13789  ! --- ipas = 2: the dynamics is computed over all the element
13790  if (ipas==2) then
13791  ! Recover all previous parameters
13792  sauphc = sauphcs(i)
13793  xlh1i = sauphc/fh0
13794  dwci = dwcis(i)
13795  sv1 = sv1p(i)
13796  sv2 = sv2p(i)
13797  sxv1 = sxv1p(i)
13798  sxv2 = sxv2p(i)
13799  beini = beini1(i)
13800  gini = 1./sqrt(1.-beini*beini)
13801  phi = phip(i)
13802  tegl = teglp(i)
13803  dxdpi = dxdpip(i)
13804  dxdki = dxdkip(i)
13805  dxdpt = dxdptp(i)
13806  dxk00 = dxk00p(i)
13807  dphii = dphiip(i)
13808  go to 5678
13809  end if
13810  ! compute the jump of phase at position of space charge computation
13811  cxlg = abs(f(9,i))/(4.*xmat*eqvl)
13812  ! FUNCTION Ha0(Z)
13813  xlh11 = (yh11+dxk00*(dkmske*yh1k1+yh1k01))*cos(dxdpt)
13814  xlh11 = xlh11 + dxdpi*yh1p1*cos(dxdpt)
13815  ! SECOND DERIVATIVES OF Ha0(Z) (division by 2 has been made)
13816  xlh112 = dxk00*dxk00*(h1aki+h1akim*dkmske+h1akm*dkmske*dkmske)*cos(dxdpt)
13817  xlh112 = xlh112 + dxdpi*dxdpi*hapi*cos(dxdpt)
13818  xlh112 = xlh112 + dxdpi*dxk00*(yh10pk+dkmske*yh11pk)*cos(dxdpt)
13819  ! THIRD DERIVATIVE of Ha0(Z)
13820  xlh113 = (dxdpi**3)/3.*happi*cos(dxdpt)
13821  xlh11 = xlh11 + xlh112 + xlh113
13822  ! FUNCTION Hb0(Z)
13823  xlh21 = (yh21+dxk00*(dkmske*yh2k1+yh2k01))*sin(dxdpt)
13824  xlh21 = xlh21 + dxdpi*yh2p1*sin(dxdpt)
13825  ! SECOND DERIVATIVE OF Hb0(Z) (division by 2 has been made)
13826  xlh212 = dxk00*dxk00*(h1bki+h1bkim*dkmske+h1bkm*dkmske**2)*sin(dxdpt)
13827  xlh212 = xlh212 + dxdpi*dxdpi*hbpi*sin(dxdpt)
13828  xlh212 = xlh212 + dxdpi*dxk00*(yh20pk+dkmske*yh21pk)*sin(dxdpt)
13829  ! THIRD DERIVATIVE OF Hb0(Z)
13830  xlh213 = (dxdpi**3)/3.*hbppi*sin(dxdpt)
13831  xlh21 = xlh21 + xlh212 + xlh213
13832  xlh1i = cxlg*(xlh11-xlh21)
13833  sauphc = fh0*xlh1i
13834 5678 continue
13835  cxlg = abs(f(9,i))/(4.*xmat*eqvl)
13836  xlh01 = (yh10+dxdki*yh1k0+dxk00*yh1k00)*cos(dxdpt)
13837  xlh02 = (yh20+dxdki*yh2k0+dxk00*yh2k00)*sin(dxdpt)
13838  xlh0i = cxlg*(xlh01-xlh02)
13839  ! -- COUPLING INTEGRALS
13840  xlp11 = (yp11+dxdki*yp1k1+dxk00*yp1k01)*cos(dxdpt)
13841  xlp21 = (yp21+dxdki*yp2k1+dxk00*yp2k01)*sin(dxdpt)
13842  xlp1i = cxlg*(xlp11-xlp21)
13843  xlp12 = (yp12+dxdki*yp1k2+dxk00*yp1k02)*cos(dxdpt)
13844  xlp22 = (yp22+dxdki*yp2k2+dxk00*yp2k02)*sin(dxdpt)
13845  xlp2i = cxlg*(xlp12-xlp22)
13846  radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
13847  if (radiu<1.e-06) then
13848  dradiu = .001*sqrt(f(3,i)*f(3,i)+f(5,i)*f(5,i))
13849  else
13850  dradiu = f(3, i)*.001*f(2, i)/radiu + f(4, i)*f(5, i)*.001/radiu
13851  end if
13852  rp = radiu
13853  rpp = dradiu
13854  ! Picht coordinates
13855  rrp = rp*sqrt(beini*gini)
13856  rrpp = rpp*sqrt(beini*gini)
13857  ! --- ipas = 1: the dynamics is computed until the position of space charge computation
13858  ! gain of energy at the position of space charge computation (not for the reference)
13859  if (ipas==1) then
13860  ! ***** PHIWC=PHI+DPHII-DPHCI0
13861  phiwc = phi + dphii
13862  ! istm: flag ==> the energy is compute at the position of space charge computation
13863  istm = ist - 1
13864  gacr = gamci(phiwc, pcresi, gini, istm, abs(f(9,i)))
13865  dwci = (gacr-gini)*xmat
13866  end if
13867  dwpi = dwci + xmat*fh0*fh0*rrp*rrp/4.*xlh0i + xmat*rrp*rrpp*fh0*fh0/2.*xlh1i
13868  ! PHASE JUMP
13869  delphi = sauphc + fh0**3*rrp*rrp/4.*xlp1i + fh0**3*rrp*rrpp/2.*xlp2i
13870  if (ipas==2) then
13871  ! kicks of energy from space charge effects are in dwp(i)
13872  if (ichaes) then
13873  f(7, i) = f(7, i) + dwpi + dwp(i)
13874  gamsor = f(7, i)/xmat
13875  if (gamsor<=1.) f(8, i) = 0.
13876  ! particle is lost
13877  if (f(8,i)==0.) go to 19
13878  besor = sqrt(1.-1./(gamsor*gamsor))
13879  ! phase jump resulting from space charge
13880  delgam = dwp(i)/xmat
13881  gamkk0 = f(7, i)/xmat
13882  bekk0 = sqrt(1.-1./(gamkk0*gamkk0))
13883  dbek21 = delgam/(bekk0**3*gamkk0**3)
13884  delsc = fh0*scdist*dbek21/2.
13885  delphi = delphi + delsc
13886  ditemp = ylg/(besor*vl) + delphi/fh
13887  f(6, i) = fs(6, i) + ditemp
13888  else
13889  f(7, i) = f(7, i) + dwpi
13890  gamsor = f(7, i)/xmat
13891  if (gamsor<=1.) f(8, i) = 0.
13892  ! particle is lost
13893  if (f(8,i)==0.) then
13894  f6i = f(6, i) - tcog
13895  write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, &
13896  int(f(9,i))
13897  if (ilost>=ngood) stop
13898  ilost = ilost + 1
13899  go to 19
13900  end if
13901  besor = sqrt(1.-1./(gamsor*gamsor))
13902  ditemp = ylg/(besor*vl) + delphi/fh
13903  f(6, i) = f(6, i) + ditemp
13904  end if
13905  end if
13906  if (ipas==1) then
13907  f(7, i) = f(7, i) + dwpi
13908  gamsor = f(7, i)/xmat
13909  if (gamsor<=1.) f(8, i) = 0.
13910  if (f(8,i)==0.) then
13911  write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f(6, i)*fh*180./pi, f(7, i) - xmat, &
13912  int(f(9,i))
13913  if (ilost>=ngood) stop
13914  ilost = ilost + 1
13915  go to 19
13916  end if
13917  besor = sqrt(1.-1./(gamsor*gamsor))
13918  ! TEST******
13919  ! DITEMP=YLG/(BESOR*VL)+DELPHI/FH
13920  ditemp = ylg/(2.*besor*vl) + delphi/fh
13921  ! 2014-Aug-08 DITEMP=ylg/(BESOR*VL)+DELPHI/FH
13922  ! cc DITEMP=(2.*XK1II*ASDL+XKMI*(EQVL-ASDL)+
13923  ! cc x XK2II*(YLG-(EQVL+ASDL)))/FH+DELPHI/FH
13924  ! ****************************
13925  f(6, i) = f(6, i) + ditemp
13926  end if
13927  if (i==icont) then
13928  if (ipas==2) then
13929  write (16, *) '* DYNAMICS AT THE OUTPUT :'
13930  write (16, 994) delphi*180./pi, delsc*180./pi, dwp(i)
13931 994 format (1x, '* PHASE JUMP ', e12.5, ' DEG CORRECTED BY :', e12.5, ' DEG ', ' SC KICK(MEV) ', e12.5)
13932  enrprin = f(7, i) - xmat
13933  write (16, 88) dwpi, enrprin, besor, f(9, i), ditemp
13934 88 format (1x, '* ENERGY GAIN : ', e14.7, ' MEV', ' ENERGY :', e14.7, ' MEV', /, 1x, '* BETA :', e12.5, /, &
13935  1x, '* CHARGE :', f5.0, ' TRANSIT TIME :', e12.5, ' SEC', /, 1x, '*')
13936  write (16, *) 'TK TKE ', tk, tke
13937  write (16, *) 'SK SKE ', sk, ske
13938  write (16, *) 'PCREST PCRESI', pcrest, pcresi
13939  end if
13940  if (ipas==1) then
13941  write (16, *) '* DYNAMICS AT THE POSITION OF SPACE CHARGE :'
13942  enrprin = f(7, i) - xmat
13943  write (16, 9944) delphi*180./pi, dwpi, enrprin, ditemp
13944 9944 format (1x, '* PHASE JUMP ', e12.5, ' DEG ', ' ENERGY GAIN : ', e14.7, ' MeV', ' ENERGY :', e14.7, ' MEV', &
13945  /, ' TRANSIT TIME :', e12.5, ' SEC', /, 1x, '*')
13946  end if
13947  end if
13948  amort = sqrt(beini*gini/(besor*gamsor))
13949  ! INTEGRALS OF THE TRANSVERSE MOTION (not computed for the reference)
13950  ! ******************
13951  ! ****** if(i.ne.ngdrf) then
13952  ! ---- integrals of E(Z)**2
13953  ! ---- (G**2+2/(G**2-1)**2)*E(z)**2
13954  cetf = f(9, i)*f(9, i)*sqcttf*sqcttf/(16.*xmat*xmat*eqvl*eqvl)
13955  ! TESTsv ********
13956  ! OLD**** CETF=CETF*cort1*cort1
13957  ! *************************************
13958  xjf0i = yfs0 + dxdki*(yfsk0+yfsck0) + dxdpi*(yfsp0+yfscp0) + dxk00*yfskc0
13959  xjf0i = xjf0i*cetf
13960  xjf1i = yfs1 + dxk00*dkmske*(yfsk1+yfsck1) + dxdpi*(yfsp1+yfscp1) + dxk00*yfskc1
13961  xjf1i = xjf1i*cetf
13962  xjf2i = yfs2 + dxk00*dkmske*(yfsk2+yfsck2) + dxdpi*(yfsp2+yfscp2) + dxk00*yfskc2
13963  xjf2i = xjf2i*cetf
13964  v1 = sv1
13965  v2 = sv2
13966  ! ---- (G**2+2/(G**2-1)**2)
13967  cetm = f(9, i)*f(9, i)*tegl/(xmat*xmat)
13968  ! TESTsv ********
13969  ! OLD**** CETM=CETM*cort1*cort1
13970  ! *************************************
13971  xmn0i = yns0 + dxdki*ynsk0 + dxdpi*ynsp0 + dxk00*ynsk0c
13972  xmn0i = xmn0i*cetm
13973  xmn1i = yns1 + dxk00*dkmske*ynsk1 + dxdpi*ynsp1 + dxk00*ynsk1c
13974  xmn1i = xmn1i*cetm
13975  xmn2i = yns2 + dxk00*dkmske*ynsk2 + dxdpi*ynsp2 + dxk00*ynsk2c
13976  xmn2i = xmn2i*cetm
13977  f0 = xjf0i + xmn0i
13978  f1 = xjf1i + xmn1i
13979  f2 = xjf2i + xmn2i
13980  ! --- 1/(B*G)**3 *dE(z)/dt
13981  ceti = fh0*abs(f(9,i))/(8.*xmat*eqvl)
13982  ! TESTsv ***************************
13983  ! OLD**** CETI=CETI*cort1
13984  ! **************************
13985  xie01 = (ye10+dxdki*ye1k0+dxk00*ye1kc0)*cos(dxdpt)
13986  xie02 = (ye20+dxdki*ye2k0+dxk00*ye2kc0)*sin(dxdpt)
13987  xie0i = -ceti*(xie01+xie02)
13988  xie11 = (ye11+dxdki*ye1k1+dxk00*ye1kc1)*cos(dxdpt)
13989  xie12 = (ye21+dxdki*ye2k1+dxk00*ye2kc1)*sin(dxdpt)
13990  xie1i = -ceti*(xie11+xie12)
13991  xie21 = (ye12+dxdki*ye1k2+dxk00*ye1kc2)*cos(dxdpt)
13992  xie22 = (ye22+dxdki*ye2k2+dxk00*ye2kc2)*sin(dxdpt)
13993  xie2i = -ceti*(xie21+xie22)
13994  xv1 = sxv1
13995  xv2 = sxv2
13996  xi0 = xie0i
13997  xi1 = xie1i
13998  xi2 = xie2i
13999  ! Transport matrix in 'PICHT' coordonates
14000  xq0 = xi0 - f0
14001  xq1 = xi1 - f1
14002  xq2 = xi2 - f2
14003  xq01 = (xq1+asdl*xq0)
14004  xq12 = (xq2+asdl*xq1)
14005  v1 = xv1 - v1
14006  v2 = xv2 - v2
14007  a11 = -xq01*(1.+(v1+v2)*eqvl*eqvl/120.)
14008  a12 = -(xq2+2.*asdl*xq1+asdl*asdl*xq0+eqvl*eqvl*((v1+v2)/120.+eqvl*v2/120.)*xq01)
14009  za = -(xq12/eqvl+v2*eqvl*eqvl*xq01/120.)
14010  zb = -((eqvl+asdl)*xq12/eqvl-eqvl*xq01/10.+v2*(eqvl+asdl)*eqvl*eqvl*xq01/120.)
14011  a21 = xq0*(1.+(v1+v2)*eqvl*eqvl/120.)
14012  a22 = xq1 + xq0*(asdl+asdl*eqvl*eqvl*(v1+v2)/120.+eqvl**3*v2/120.)
14013  zc = xq1/eqvl + v2*eqvl*eqvl*xq0/120.
14014  zd = (asdl+eqvl)*xq1/eqvl - (eqvl/10.+v2*(eqvl+asdl)*eqvl*eqvl/120.)*xq0
14015 
14016  tma = 1./(1.-za-zc*zb/(1.-zd))
14017  t11 = (a11+zb*a21/(1.-zd))*tma
14018  t12 = (a12+zb*a22/(1.-zd))*tma
14019  t21 = (a21+zc*t11)/(1.-zd)
14020  t22 = (a22+zc*t12)/(1.-zd)
14021  vr11 = (1.+t11+dcum*t21)
14022  vr12 = (t12+dcum*(1.+t22))
14023  vr21 = t21
14024  vr22 = 1. + t22
14025  if (i==icont) then
14026  detre = vr11*vr22 - vr12*vr21
14027  write (16, 8921) vr11, vr12, vr21, vr22, detre
14028 8921 format (2x, ' TRANSVERSE CANONICAL MATRIX:(cm,radian) ', /, 2x, ' VR11:', e12.5, ' VR12:', e12.5, /, 2x, &
14029  ' VR21:', e12.5, ' VR22:', e12.5, /, 2x, ' DETERMINANT :', e12.5, //)
14030  end if
14031  ! REAL MATRIX
14032  a11 = vr11*amort
14033  a12 = vr12*amort
14034  a21 = vr21*amort
14035  a22 = vr22*amort
14036  ! omment ** cumulative matrix (particle 1)
14037  ! omment tables R(,) ET T(,,,)
14038  ! omment IF (I .EQ. 1.AND.IPAS.EQ.2) THEN
14039  ! omment STA11=VR11*SA11+VR12*SA21
14040  ! omment STA12=VR11*SA12+VR12*SA22
14041  ! omment STA21=VR21*SA11+VR22*SA21
14042  ! omment STA22=VR21*SA12+VR22*SA22
14043  ! omment SA11=STA11
14044  ! omment SA12=STA12
14045  ! omment SA21=STA21
14046  ! omment SA22=STA22
14047  ! omment SAA11=SA11*AMORT
14048  ! omment SAA12=SA12*AMORT
14049  ! omment SAA21=SA21*AMORT
14050  ! omment SAA22=SA22*AMORT
14051  ! omment RS(1,1) =SAA11
14052  ! omment RS(1,2) =SAA12
14053  ! omment RS(2,1) =SAA21
14054  ! omment RS(2,2) =SAA22
14055  ! omment RS(3,3) =SAA11
14056  ! omment RS(3,4) =SAA12
14057  ! omment RS(4,3) =SAA21
14058  ! omment RS(4,4) =SAA22
14059  ! omment DO IA=1,6
14060  ! omment DO IB=1,6
14061  ! omment R(IA,IB)=RCUL(IA,IB)
14062  ! omment ENDDO
14063  ! omment ENDDO
14064  ! omment CALL MFORDRE(RCUL,RS,R)
14065  ! omment ENDIF
14066  ! BEAM COORDINATES
14067  fxt1 = a11*f(2, i) + a12*f(3, i)*1.e-03
14068  fxt2 = a21*f(2, i) + a22*f(3, i)*1.e-03
14069  fxt3 = a11*f(4, i) + a12*f(5, i)*1.e-03
14070  fxt4 = a21*f(4, i) + a22*f(5, i)*1.e-03
14071  f(2, i) = fxt1
14072  f(3, i) = fxt2*1.e03
14073  f(4, i) = fxt3
14074  f(5, i) = fxt4*1.e03
14075  if (i==icont) then
14076  ! ** CURRENT MATRIX
14077  stta11 = vr11*sact11 + vr12*sact21
14078  stta12 = vr11*sact12 + vr12*sact22
14079  stta21 = vr21*sact11 + vr22*sact21
14080  stta22 = vr21*sact12 + vr22*sact22
14081  sact11 = stta11
14082  sact12 = stta12
14083  sact21 = stta21
14084  sact22 = stta22
14085  saa11 = sact11*amort
14086  saa12 = sact12*amort
14087  saa21 = sact21*amort
14088  saa22 = sact22*amort
14089  det = a11*a22 - a12*a21
14090  write (16, 992) a11, a12*1.e-3, a21*1.e3, a22, det, amort
14091 992 format (1x, '* TRANSVERSE MATRIX (cm,mrd)', /, 1x, '*', e12.5, 3x, e12.5, /, 1x, '*', e12.5, 3x, e12.5, /, &
14092  1x, '* DETERMINANT :', e12.5, ' DUMPING OF ENERGY :', e12.5)
14093  write (16, *) '*'
14094  write (16, 559) f(2, i), f(3, i), f(4, i), f(5, i)
14095 559 format (' * TRANVERSE COORDINATES AT OUTPUT ', /, 1x, '* X :', e12.5, ' CM XP :', e12.5, ' MRD ', /, 1x, &
14096  '* Y :', e12.5, ' CM YP :', e12.5, ' MRD')
14097  if (ipas==2) write (16, *) '********** END OF FOLLOWED PARTICLE ********'
14098  end if
14099  ! ***** endif
14100 19 end do
14101  return
14102  end subroutine boucle
14103  ! *******************************************************************
14104  ! SUBROUTINE bunparm(v,dp,harm,prlim)
14105  ! BUNCHER (NO SPACE CHARGE EFFECT)
14106  ! *******************************************************************
14107  subroutine bunparm(v, dp, harm, prlim)
14108  implicit real *8(a-h, o-z)
14109  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14110  common /rigid/boro
14111  common /consta/vl, pi, xmat, rpel, qst
14112  common /dyn/tref, vref
14113  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
14114  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
14115  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14116  common /faisc/f(10, iptsz), imax, ngood
14117  common /etcom/cog(8), exten(17), fd(iptsz)
14118  common /fene/wdisp, wphas, wx, wy, rlim, ifw
14119  common /corec/tref1
14120  common /qmoyen/qmoy
14121  common /aerp/vphase, vfield, ierpf
14122  common /itvole/itvol, imamin
14123  common /compt/nrres, nrtre, nrbunc, nrdbun
14124  common /shif/dtiph, shift
14125  common /tofev/ttvols
14126  common /fcont/ifcont
14127  logical ifcont
14128  character *1 cr
14129  dimension vecx(1)
14130  logical chasit, itvol, imamin, shift
14131  ! ENVELOPE
14132  call stapl(davtot*10.)
14133  ! xx ilost=0
14134  twopi = 2.*pi
14135  freq = fh/twopi
14136  wavel = vl/freq
14137  fcpi = fh*180./pi
14138  ! print out on terminal of transport element # on one and the same line
14139  nrbunc = nrbunc + 1
14140  cr = char(13)
14141  write (6, 8254) nrtre, nrbunc, cr
14142 8254 format ('Transport element:', i5, ' Buncher :', i5, a1, $)
14143  if (harm<=0.) harm = 1.
14144  rhs = prlim*prlim
14145  ! test window
14146  call reject(ilost)
14147  ! Reshuffles f(i,j) array after window (now done in 'reject')
14148  ! call shuffle
14149  tcog = 0.
14150  bcog = 0.
14151  do np = 1, ngood
14152  tcog = tcog + f(6, np)
14153  gpa = f(7, np)/xmat
14154  bcog = sqrt(1.-1./(gpa*gpa)) + bcog
14155  end do
14156  tcog = tcog/float(ngood)
14157  bcog = bcog/float(ngood)
14158  gcog = 1./sqrt(1.-bcog*bcog)
14159  encog = xmat*gcog - xmat
14160  ! adjustement of the phase of RF w.r.t. the T.O.F.
14161  xkpi = 0.
14162  if (imamin) then
14163  ttvpi = harm*ttvols*fcpi
14164  xkpi = ttvpi/360.
14165  ixkpi = int(xkpi)
14166  xkpi = (xkpi-float(ixkpi))*360.
14167  write (16, *) ' *** TOF correction:', -xkpi, ' deg'
14168  dp = dp - xkpi*pi/180.
14169  write (16, *) ' ***phase of RF adjusted : ', dp*180./pi, ' deg'
14170  end if
14171  ! 20/08/2009 delay of phase of the reference at input w.r.t. the synchronous phase
14172  ! 20/08/2009 ttvpi=harm*ttvols*fcpi
14173  ! 20/08/2009 xkpi=ttvpi/180.
14174  ! 20/08/2009 ixkpi=xkpi+0.5
14175  ! 20/08/2009 ixkpi=ixkpi*180
14176  ! 20/08/2009 xkpc=cos(ixkpi*pi/180.)
14177  ! 20/08/2009 xkpi=ttvpi-float(ixkpi)
14178  ! 20/08/2009 if(itvol.and.imamin)
14179  ! 20/08/2009 * write(16,8975) dp*180./pi,xkpi
14180  ! 20/08/2009 8975 format('***previous phase offset: ',e12.5,' deg',/,
14181  ! 20/08/2009 * '***new phase offset: ',e12.5,' deg')
14182  ! start of write to file '.short' for buncher
14183  idav = idav + 1
14184  iitem(idav) = 8
14185  dav1(idav, 1) = v
14186  dav1(idav, 2) = dp*180./pi
14187  dav1(idav, 3) = prlim
14188  dav1(idav, 4) = davtot*10.
14189  if (itvol) dav1(idav, 5) = -xkpi
14190  ! end
14191  write (16, 178)
14192 178 format (/, ' Dynamics at the input', /, 5x, ' BETA GAMMA ENERGY(MeV) ', ' TOF(deg) TOF(sec)')
14193  write (16, 1788) bcog, gcog, encog, tcog*fcpi, tcog
14194 1788 format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
14195  e0t = harm*v/(bcog*wavel)
14196  ! random or systematic error on RF level
14197  if (ierpf>0) then
14198  ! systematic error on RF level
14199  if (ierpf==1) e0t = e0t*(1.+vfield)
14200  ! random error on RF level
14201  if (ierpf>=2) then
14202  len = 1
14203  call rlux(vecx, len)
14204  r1 = (2.*vecx(1)-1.)*vfield
14205  e0t = e0t*(1.+r1)
14206  end if
14207  end if
14208  cay = harm*twopi/(bcog*gcog*wavel)
14209  caysq = cay**2
14210  con = twopi*e0t*qmoy/xmat
14211  rad = pi/180.
14212  ! systematic error on phase
14213  if (ierpf==1) dp = dp + vphase*rad
14214  ! random error on phase
14215  if (ierpf>=2) then
14216  len = 1
14217  call rlux(vecx, len)
14218  r1 = (2.*vecx(1)-1.)*vphase*rad
14219  dp = dp + r1
14220  end if
14221  ! shift=true => reference and COG seperated, otherwise reference=COG
14222  ! --- save the reference
14223  ovref = vref
14224  otref = tref
14225  ! --- shift = false: the reference particle is the cog
14226  if (shift) then
14227  ovref = vref
14228  beref = vref/vl
14229  gamref = 1./sqrt(1.-beref*beref)
14230  older = xmat*gamref
14231  else
14232  tref = tcog
14233  vref = bcog*vl
14234  ovref = vref
14235  beref = bcog
14236  gamref = 1./sqrt(1.-beref*beref)
14237  older = xmat*gamref
14238  end if
14239  ! --- if imamin = false: phase setting has been forced equal to dp, otherwise phase setting has been adjusted
14240  dgr = v*cos(harm*ttvols*fh+dp)*qmoy
14241  ewer = older + dgr
14242  gor = ewer/xmat
14243  vref = vl*sqrt(1.-1./(gor*gor))
14244  enrprin = older - xmat
14245  write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
14246 165 format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
14247  wsync = 0.
14248  bcour = 0.
14249  tcog = 0.
14250  do np = 1, ngood
14251  rs = f(2, np)**2 + f(4, np)**2
14252  a = harm*(f(6,np)-tref+ttvols)*fh + dp
14253  rs = rs*1.e-04
14254  ! 20/08/2009 s=sin(a)*xkpc
14255  s = sin(a)
14256  w = f(7, np) - xmat
14257  bg = sqrt(w/xmat*(2.+w/xmat))
14258  ! conversion cm-->m and mrd--->rd
14259  f2 = f(2, np)
14260  f4 = f(4, np)
14261  f3 = f(3, np)*1.e-03
14262  f5 = f(5, np)*1.e-03
14263  bgx = f3*bg
14264  bgy = f5*bg
14265  cayrsq = caysq*rs
14266  arg = cayrsq/4.
14267  xi0 = 1. + arg*(1.+arg*(.25+arg/36.))
14268  ! dw=v*cos(a)*xi0*qmoy
14269  dw = v*cos(a)*xi0*f(9, np)
14270  ! 20/08/2009 dw=dw*xkpc
14271  wb = w + .5*dw
14272  bgav = sqrt(wb/xmat*(2.+wb/xmat))
14273  gav = 1. + wb/xmat
14274  bav = bgav/gav
14275  bcour = bcour + bav
14276  wf = w + dw
14277  bgf = sqrt(wf/xmat*(2.+wf/xmat))
14278  xi1okr = .5 + .25*arg + arg**2/24.
14279  del = -con*s*(1.-bav*bcog)*xi1okr/bav
14280  tcog = tcog + f(6, np)
14281  f3 = (bgx+del*f2)/bgf
14282  f(3, np) = f3*1.e03
14283  f5 = (bgy+del*f4)/bgf
14284  f(5, np) = f5*1.e03
14285  f(7, np) = wf + xmat
14286  wsync = wsync + wf
14287  end do
14288  wsync = wsync/float(ngood)
14289  bcour = bcour/float(ngood)
14290  tcog = tcog/float(ngood)
14291  ! Test window
14292  call reject(ilost)
14293  ! Reshuffles f(i,j) array after window (now done in 'reject')
14294  ! call shuffle
14295  ! new output
14296  ! shift=true => reference and COG seperated, otherwise reference=COG
14297  engain = wsync - encog
14298  if (shift) then
14299  beref = vref/vl
14300  gamref = 1./sqrt(1.-beref*beref)
14301  enref = ewer - xmat
14302  else
14303  tref = tcog
14304  vref = bcour*vl
14305  beref = bcour
14306  enref = wsync
14307  dgr = engain
14308  end if
14309  if (itvol) ttvols = tref
14310  write (16, 3777)
14311 3777 format (/, ' Dynamics at the output', /, 5x, ' BETA dW(MeV) ENERGY(MeV) ', ' TOF(deg) TOF(sec)')
14312  write (16, 3473) beref, dgr, enref, fh*tref*180./pi, tref
14313 3473 format (' REF ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
14314  write (16, 1789) bcour, engain, wsync, tcog*fh*180./pi, tcog
14315 1789 format (' COG ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
14316  ! dave start for buncher
14317  dav1(idav, 36) = ngood
14318  ! as beam passed through buncher, assume bunched beam
14319  ifcont = .false.
14320  write (16, *) 'After buncher, bunched beam assumed'
14321  call emiprt(0)
14322  ! dave end
14323  ! xx3928 FORMAT(' # ',i5,1x,7(f10.2,1x))
14324  return
14325  end subroutine bunparm
14326  ! *******************************************************************
14327  ! SUBROUTINE refer
14328  ! change the longitudinal position of the reference
14329 
14330  ! ---- IREF =0 and IREFW = 0: dewref is dW/W where W is the kinetic
14331  ! energy of the old reference
14332  ! ---- IREF =0 and IREFW = 1: dewref is dW (MeV) relative to the
14333  ! kinetic energy of the old reference
14334  ! ---- IREF =0 and IREFW = 2: dewref is dW (MeV) is new reference
14335  ! energy and dbref new reference
14336  ! phase (deg) in abs. units
14337  ! ---- IREF =1 and IREFW = 0: dewref is dW/W where W is the kinetic
14338  ! energy of the c.o.g
14339  ! ---- IREF =1 and IREFW = 1: dewref is dW (MeV) relative to the
14340  ! kinetic energy of the c.o.g.
14341  ! *******************************************************************
14342  subroutine refer
14343  implicit real *8(a-h, o-z)
14344  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14345  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14346  common /dyn/tref, vref
14347  common /faisc/f(10, iptsz), imax, ngood
14348  common /qmoyen/qmoy
14349  common /consta/vl, pi, xmat, rpel, qst
14350  common /newref/dephas, dewref, iref, irefw
14351  common /tapes/in, ifile, meta
14352  common /itvole/itvol, imamin
14353  common /tofev/ttvols
14354  logical itvol, imamin
14355  ! ---- save reference
14356  avref = vref
14357  atref = tref
14358  attvols = ttvols
14359  if (irefw==2) then
14360  wnref = dewref
14361  gnref = wnref/xmat + 1.
14362  bref = sqrt(gnref*gnref-1.)/gnref
14363  ! ---- set tref in sec based on dephas (deg)
14364  delt = dephas*pi/(fh*180.)
14365  ! ------ the new reference is:
14366  tref = delt
14367  vref = bref*vl
14368  if (itvol) ttvols = tref
14369  end if
14370  if (iref==0) then
14371  if (irefw==0) then
14372  bref = vref/vl
14373  gref = 1./sqrt(1-bref*bref)
14374  dbref = bref*dewref/(gref*(gref+1.))
14375  ! ---- change dephas (deg) in delt (sec)
14376  delt = dephas*pi/(fh*180.)
14377  ! ------ the new reference is:
14378  tref = tref + delt
14379  vref = vref + dbref*vl
14380  if (itvol) ttvols = tref
14381  end if
14382  if (irefw==1) then
14383  bref = vref/vl
14384  gref = 1./sqrt(1.-bref*bref)
14385  wref = (gref-1.)*xmat
14386  wnref = wref + dewref
14387  gnref = wnref/xmat + 1.
14388  bref = sqrt(gnref*gnref-1.)/gnref
14389  ! ---- change dephas (deg) in delt (sec)
14390  delt = dephas*pi/(fh*180.)
14391  ! ------ the new reference is:
14392  tref = tref + delt
14393  vref = bref*vl
14394  if (itvol) ttvols = tref
14395  end if
14396  end if
14397  if (iref==1) then
14398  ! ----- c.o.g. of the bunch is the new reference
14399  tcog = 0.
14400  bcog = 0.
14401  do i = 1, ngood
14402  tcog = tcog + f(6, i)
14403  gpai = f(7, i)/xmat
14404  bcog = bcog + sqrt(1.-1./(gpai*gpai))
14405  end do
14406  tcog = tcog/float(ngood)
14407  bcog = bcog/float(ngood)
14408  gcog = 1./sqrt(1-bcog*bcog)
14409  wcog = (gcog-1.)*xmat
14410  ! ---- change dephas (deg) in delt (sec)
14411  delt = dephas*pi/(fh*180.)
14412  if (irefw==0) then
14413  wrefn = wcog + wcog*dewref/100.
14414  ! ------ the new reference is:
14415  tref = tcog + delt
14416  ! vref=(bcog+dbcog)*vl
14417  grefn = wrefn/xmat + 1.
14418  vref = vl*sqrt(grefn*grefn-1.)/grefn
14419  if (itvol) ttvols = tref
14420  end if
14421  if (irefw==1) then
14422  wncog = wcog + dewref
14423  gncog = wncog/xmat + 1.
14424  bcog = sqrt(gncog*gncog-1.)/gncog
14425  ! ------ the new reference is:
14426  tref = tcog + delt
14427  vref = bcog*vl
14428  if (itvol) ttvols = tref
14429  end if
14430  end if
14431  baref = avref/vl
14432  garef = 1./sqrt(1.-baref*baref)
14433  waref = (garef-1.)*xmat
14434  bnref = vref/vl
14435  gnref = 1./sqrt(1.-bnref*bnref)
14436  wnref = (gnref-1.)*xmat
14437  fcpi = fh*180/pi
14438  write (16, 20) atref*fcpi, attvols*fcpi, waref
14439 20 format (3x, '**before NREF', /, 5x, 'tof of the reference: ', e12.5, ' deg tof for adjustments: ', e12.5, &
14440  ' deg energy of reference: ', e12.5, ' MeV')
14441  write (16, 21) tref*fcpi, ttvols*fcpi, wnref
14442 21 format (3x, '**after NREF', /, 5x, 'tof of the reference: ', e12.5, ' deg tof for adjustments: ', e12.5, &
14443  ' deg energy of reference: ', e12.5, ' MeV')
14444  return
14445  end subroutine refer
14446  ! *******************************************************************
14447  ! SUBROUTINE steer(fld,nvf)
14448  ! TRANSFORM BEAM THRU THIN STEERER
14449  ! ---- MAGNETIC STEERER
14450  ! ---- PARAMETERS: fld (Tm), nvf
14451  ! where fld is the integrated field
14452  ! if nvf=0, horizontal magnetic steerer
14453  ! if nvf=1, vertical magnetic steerer
14454 
14455  ! ---- ELECTROSTATIC STEERER
14456  ! This is a zero length element: the length shown below is
14457  ! ONLY used for kick calculation.
14458  ! ---- PARAMETERS: fld (kV*m/m), nvf
14459  ! where fld is Plate Voltage * plate length/plate separation.
14460  ! if nvf=2, horziontal electrostatic steerer
14461  ! if nvf=3, vertical electrostatic steerer
14462 
14463  ! -----ANGULAR DISPLACEMENTS DUE TO STEERING
14464  ! *******************************************************************
14465  subroutine steer(fld, nvf)
14466  implicit real *8(a-h, o-z)
14467  ! 4/15/14 - Daniel Alt: Added electrostatic steerers.
14468  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14469  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14470  common /dyn/tref, vref
14471  common /consta/vl, pi, xmat, rpel, qst
14472  common /rigid/boro
14473  common /faisc/f(10, iptsz), imax, ngood
14474  common /etcom/cog(8), exten(17), fd(iptsz)
14475  common /qmoyen/qmoy
14476  common /dcspa/iesp
14477  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
14478  common /tapes/in, ifile, meta
14479  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
14480  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
14481  common /compt/nrres, nrtre, nrbunc, nrdbun
14482  character *1 cr
14483  logical iesp, ichaes
14484  ! print out on terminal of transport element # on one and the same line
14485  nrtre = nrtre + 1
14486  cr = char(13)
14487  write (6, 8254) nrtre, nrres, cr
14488 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
14489  if (nvf==0) then
14490  ! horizontal magnetic steerer
14491  write (16, *) 'Horizontal magnetic steerer: ', fld, ' Tm'
14492  do i = 1, ngood
14493  const = xmat*1.e8/(f(9,i)*vl)
14494  gpai = f(7, i)/xmat
14495  bpai = sqrt(1.-1./(gpai*gpai))
14496  dispx = fld/(const*gpai*bpai)*1000.
14497  f(3, i) = f(3, i) + dispx
14498  end do
14499  else if (nvf==1) then
14500  ! vertical magnetic steerer
14501  write (16, *) 'Vertical magnetic steerer: ', fld, ' Tm'
14502  do i = 1, ngood
14503  const = xmat*1.e8/(f(9,i)*vl)
14504  gpai = f(7, i)/xmat
14505  bpai = sqrt(1.-1./(gpai*gpai))
14506  dispy = fld/(const*gpai*bpai)*1000.
14507  f(5, i) = f(5, i) + dispy
14508  end do
14509  else if (nvf==2) then
14510  ! horizontal electrostatic steerer
14511  write (16, *) 'Horizontal electrostatic steerer: ', fld, ' kV*m/m'
14512  do i = 1, ngood
14513  gpai = f(7, i)/xmat
14514  const = (gpai/(gpai*gpai-1.))*f(9, i)
14515  dispx = const*fld/xmat
14516  f(3, i) = f(3, i) + dispx
14517  end do
14518  else if (nvf==3) then
14519  ! vertical electrostatic steerer
14520  write (16, *) 'Vertical electrostatic steerer: ', fld, ' kV*m/m'
14521  do i = 1, ngood
14522  gpai = f(7, i)/xmat
14523  const = (gpai*gpai/(gpai*gpai-1.))*f(9, i)
14524  dispy = const*fld/xmat
14525  f(5, i) = f(5, i) + dispy
14526  end do
14527  else
14528  ! error on input
14529  write (16, *) 'Wrong value for NVF in STEERER'
14530  stop
14531  end if
14532  return
14533  end subroutine steer
14534  ! *******************************************************************
14535  ! SUBROUTINE emiprt(L)
14536  ! following EMIT or EMITL card, store data in arrays to be printed
14537  ! by subroutine "daves"
14538  ! L=0 corresponds to EMIT (do not read and print a label)
14539  ! L=1 corresponds to EMITL (do read and print a label in dynac.short)
14540  ! look for the statistics with EXT2D and returns them in arrays dav1
14541  ! and dav2
14542  ! IDCH EQ 1: WITH CHASE TEST
14543  ! IDCH NE 1: OTHERWISE
14544 
14545  ! cog(1) : Energy(MeV)
14546  ! cog(3) : t.o.f. (sec)
14547  ! cog(4) : x-direction (cm)
14548  ! cog(5) : xp(mrd)
14549  ! cog(6) : y-direction (cm)
14550  ! cog(7) : yp(mrd)
14551 
14552  ! exten(1) : Sum( dE*dE ) MeV*MeV
14553  ! exten(2) : Sum( dE*dPHase ) MeV*rad
14554  ! exten(3) : Sum( dPHase*dPHase ) rad*rad
14555  ! exten(4) : Sum( x*x ) cm*cm
14556  ! exten(5) : Sum( xp*xp ) mrad*mrad
14557  ! exten(6) : Sum( y*y ) cm*cm
14558  ! exten(7) : Sum( yp*yp ) mrad*mrad
14559  ! exten(8) : Sum( x*xp ) cm*mrad
14560  ! exten(9) : Sum( y*yp ) cm*mrad
14561  ! *******************************************************************
14562  subroutine emiprt(l)
14563  implicit real *8(a-h, o-z)
14564  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14565  common /etchas/fractx, fracty, fractl
14566  common /dyn/tref, vref
14567  common /faisc/f(10, iptsz), imax, ngood
14568  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
14569  common /davprt/shortl
14570  common /qmoyen/qmoy
14571  common /etcom/cog(8), exten(17), fd(iptsz)
14572  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
14573  common /etcha3/ichxyz(iptsz)
14574  common /speda/dave, idave
14575  common /cptemit/xltot(maxcell1), nbemit
14576  common /consta/vl, pi, xmat, rpel, qst
14577  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14578  common /mcs/imcs, ncstat, cstat(20)
14579  common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
14580  common /shortl/davprt
14581  logical dave, chasit
14582  dimension foo(20, 9), ndp(20)
14583  character *80 davprt(maxcell1), shortl
14584 
14585  nbemit = nbemit + 1
14586  do i = 1, ngood
14587  ichxyz(i) = 1
14588  end do
14589  xltot(nbemit) = davtot
14590  idav = idav + 1
14591  iitem(idav) = 3
14592  dav1(idav, 40) = fh
14593  do i = 1, ngood
14594  ichas(i) = 1
14595  end do
14596  iarg = 1
14597  if (l==1) davprt(idav) = shortl
14598  call cdg(iarg)
14599  encog = cog(1)
14600  gcog = encog/xmat
14601  bcog = sqrt(1.-1./(gcog*gcog))
14602  tcog = cog(3)
14603  call ext2d(1)
14604  ! --- qdisp : average dispersion (MeV)
14605  ! --- sqmdv: emittance (MeV*rad)
14606  qdisp = 2.*sqrt(exten(1))
14607  qmdv = exten(1)*exten(3) - exten(2)*exten(2)
14608  sqmdv = 4.*pi*sqrt(qmdv)
14609  ! --- qdp : average extension in phase (rad)
14610  qdp = 2.*sqrt(exten(3))
14611  ! --- cor12: coefficient of correlation in (dE, dPHI)
14612  cor12 = exten(2)/sqrt(exten(1)*exten(3))
14613  ! sup pent12=sqrt(exten(1)/exten(3))/cor12
14614  ! sup pent21=sqrt(exten(1)/exten(3))*cor12
14615  ! sup qdpde=qdp*180./pi
14616  ! --- particle reference
14617  ! dav1(idav,3): relativistic beta
14618  ! dav1(idav,4): Kinetic energy (MeV)
14619  ! dav1(idav,5): phase (in deg. w.r.t. k*pi)
14620  beref = vref/vl
14621  gref = 1./sqrt(1.-beref*beref)
14622  dav1(idav, 3) = beref
14623  dav1(idav, 4) = xmat*(gref-1.)
14624  dav1(idav, 5) = -(int(tref*fh/pi+0.5)-tref*fh/pi)*180.
14625  ! print out absolute TOF
14626  dav1(idav, 5) = (tref*fh/pi)*180.
14627  ! --- c.o.g of the bunch
14628  ! dav1(idav,6): Kinetic energy (MeV)
14629  ! dav1(idav,7): phase (in deg. w.r.t. k*pi)
14630  phnw = -(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
14631  ! print out absolute TOF
14632  phnw = (tcog*fh/pi)*180.
14633  dav1(idav, 6) = encog - xmat
14634  dav1(idav, 7) = phnw
14635  ! ---- deviation between the fictious reference and the c.o.g. of the bunch
14636  ! dav1(idav,8) : deviation in energy (MeV)
14637  ! dav1(idav,9) : deviation of phase (deg)
14638  dav1(idav, 8) = encog - xmat - dav1(idav, 4)
14639  dav1(idav, 9) = phnw - dav1(idav, 5)
14640  ! ---- statistics in z-zp
14641  ! --- dav1(idav,10) : extension dPHI (deg)
14642  ! --- dav1(idav,11) : dispersion dE (MeV)
14643  ! --- dav1(idav,12) : emittance (MeV*rad)
14644  ! --- dav1(idav,23) : correlation in between dE an dPHI
14645  dav1(idav, 10) = qdp*180./pi
14646  dav1(idav, 11) = qdisp
14647  dav1(idav, 12) = sqmdv/pi
14648  dav1(idav, 23) = cor12
14649  ! sup dav1(idav,39)=sqmdv*180./(pi*pi)
14650  ! sup Ez(ns.keV)
14651  ! sup dav1(idav,12)=sqmdv*(1.E09)/(pi*fh)
14652  ! ---- statistics in x-xp and y-yp
14653  trqtx = exten(4)*exten(5) - exten(8)*exten(8)
14654  trqpy = exten(6)*exten(7) - exten(9)*exten(9)
14655  surxth = 4.*pi*sqrt(trqtx)
14656  suryph = 4.*pi*sqrt(trqpy)
14657  qditax = 2.*sqrt(exten(4))
14658  qdiant = 2.*sqrt(exten(5))
14659  qditay = 2.*sqrt(exten(6))
14660  qdianp = 2.*sqrt(exten(7))
14661  ! dav1(idav,13): extension in x (mm)
14662  ! dav1(idav,14): extension in xp (mrad)
14663  ! --- dav1(idav,15): correlation between x and xp
14664  dav1(idav, 13) = qditax*10.
14665  dav1(idav, 14) = qdiant
14666  dav1(idav, 15) = 0.
14667  if (exten(4)/=0. .and. exten(5)/=0.) dav1(idav, 15) = exten(8)/sqrt(exten(4)*exten(5))
14668  ! Emittance(norm) x-xp (mm*mrad)
14669  dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
14670  ! Emittance(non norm) x-xp (mm*mrad)
14671  dav1(idav, 17) = surxth*10./pi
14672  ! --- dav1(idav,18): y-extension (mm)
14673  ! --- dav1(idav,19): yp-extension (mrad)
14674  ! --- dav1(idav,20): correlation between y and yp
14675  dav1(idav, 20) = 0.
14676  if (exten(6)/=0. .and. exten(7)/=0.) dav1(idav, 20) = exten(9)/sqrt(exten(6)*exten(7))
14677  dav1(idav, 18) = qditay*10.
14678  dav1(idav, 19) = qdianp
14679  ! dav1(idav,21) : Emittance(norm) y-yp (pi*mm*mrad)
14680  dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
14681  ! dav1(idav,22) : Emittance(non norm) y-yp (mm*mrad)
14682  dav1(idav, 22) = suryph*10./pi
14683  dav1(idav, 30) = float(ngood)
14684  dav1(idav, 31) = cog(4)*10.
14685  dav1(idav, 32) = cog(5)
14686  dav1(idav, 33) = cog(6)*10.
14687  dav1(idav, 34) = cog(7)
14688  ! next card to indicate no chase
14689  dav1(idav, 26) = 0.
14690  ! --- statistics with chase
14691  if (chasit) then
14692  dav2(idav, 31) = fractx
14693  dav2(idav, 32) = fracty
14694  dav2(idav, 33) = fractl
14695  ! longitudinal direction
14696  call chasel
14697  do i = 1, ngood
14698  ichxyz(i) = ichas(i)
14699  end do
14700  iarg = 1
14701  call cdg(iarg)
14702  encog = cog(1)
14703  gcog = encog/xmat
14704  bcog = sqrt(1.-1./(gcog*gcog))
14705  enprt = encog - xmat
14706  call ext2d(1)
14707  ! qdisp : average dispersion dE (MeV)
14708  ! sqmdv: longitudinal emittance (MeV*rad)
14709  qdisp = 2.*sqrt(exten(1))
14710  qmdv = exten(1)*exten(3) - exten(2)*exten(2)
14711  sqmdv = 4.*pi*sqrt(qmdv)
14712  ! qdp : average extension dPHI (rad)
14713  qdp = 2.*sqrt(exten(3))
14714  ! cor12: coefficient of correlation in (dE, dPHI)
14715  cor12 = exten(2)/sqrt(exten(1)*exten(3))
14716  ! sup pent12=sqrt(exten(1)/exten(3))/cor12
14717  ! sup pent21=sqrt(exten(1)/exten(3))*cor12
14718  ! sup qdpde=qdp*180./pi
14719  ! --- fictitious reference
14720  ! dav2(idav,3): relativistic beta
14721  ! dav2(idav,4): Kinetic energy (MeV)
14722  ! dav2(idav,5): phase (in deg. w.r.t. k*pi)
14723  beref = vref/vl
14724  gref = 1./sqrt(1.-beref*beref)
14725  dav2(idav, 3) = beref
14726  dav2(idav, 4) = xmat*(gref-1.)
14727  dav2(idav, 5) = (int(tref*fh/pi+0.5)-tref*fh/pi)*180.
14728  ! --- c.o.g of the bunch
14729  ! dav2(idav,6): Kinetic energy (MeV)
14730  ! dav2(idav,7): phase (in deg. w.r.t. k*pi)
14731  phnw = -(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
14732  dav2(idav, 6) = encog - xmat
14733  dav2(idav, 7) = phnw
14734  ! ---- deviation between fictitious reference and c.o.g.
14735  ! dav2(idav,8) : deviation in energy (MeV)
14736  ! dav2(idav,9) : deviation of phase (deg)
14737  dav2(idav, 8) = encog - xmat - dav2(idav, 4)
14738  dav2(idav, 9) = phnw - dav2(idav, 5)
14739  ! ---- caracteristics of the bunch in longitudinal plane (dE, dPHI)
14740  ! dav2(idav,10) : dPHI extension (deg)
14741  ! dav2(idav,11) : dispersion dE (MeV)
14742  ! dav2(idav,12) : emittance (MeV*rad)
14743  ! dav2(idav,23) : coefficient of correlation in (dE, dPHI)
14744  dav2(idav, 10) = qdp*180./pi
14745  dav2(idav, 11) = qdisp
14746  dav2(idav, 12) = sqmdv/pi
14747  dav2(idav, 23) = cor12
14748  ! sup dav2(idav,39)=sqmdv*180./(pi*pi)
14749  ! sup Ez(ns.keV)
14750  ! sup dav2(idav,12)=sqmdv*(1.E09)/(pi*fh)
14751  ! --- chase in x-xp
14752  call chasex
14753  do i = 1, ngood
14754  ichxyz(i) = ichas(i)*ichxyz(i)
14755  end do
14756  iarg = 1
14757  call cdg(iarg)
14758  encog = cog(1)
14759  gcog = encog/xmat
14760  bcog = sqrt(1.-1/(gcog*gcog))
14761  dav2(idav, 26) = cog(4)*10.
14762  dav2(idav, 27) = cog(5)
14763  call ext2d(1)
14764  trqty = exten(4)*exten(5) - exten(8)*exten(8)
14765  surxth = 4.*pi*sqrt(trqty)
14766  qditax = 2.*sqrt(exten(4))
14767  qdiant = 2.*sqrt(exten(5))
14768  ! cc below for fourth line of EMIT output
14769  ! ---- caracteristics of the bunch in x-direction
14770  ! dav2(idav,13): x-extension (mm)
14771  ! dav2(idav,14): xp-extension (mrad)
14772  ! dav2(idav,15): coefficient of correlation in plane (x, xp)
14773  dav2(idav, 13) = qditax*10.
14774  dav2(idav, 14) = qdiant
14775  dav2(idav, 15) = 0.
14776  if (exten(4)/=0. .and. exten(5)/=0.) dav1(idav, 15) = exten(8)/sqrt(exten(4)*exten(5))
14777  ! Emittance(norm) x-xp (pi*mm*mrad)
14778  dav2(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
14779  ! Emittance(non norm) in x-xp (mm*mrad)
14780  dav2(idav, 17) = surxth*10./pi
14781  ! cc below for fourth line of EMIT output
14782  ! --- chase in x-xp
14783  call chasey
14784  do i = 1, ngood
14785  ichxyz(i) = ichas(i)*ichxyz(i)
14786  end do
14787  iarg = 1
14788  call cdg(iarg)
14789  encog = cog(1)
14790  gcog = encog/xmat
14791  bcog = sqrt(1.-1./(gcog*gcog))
14792  dav2(idav, 28) = cog(6)*10.
14793  dav2(idav, 29) = cog(7)
14794  call ext2d(1)
14795  trqpz = exten(6)*exten(7) - exten(9)*exten(9)
14796  suryph = 4.*pi*sqrt(trqpz)
14797  qditay = 2.*sqrt(exten(6))
14798  qdianp = 2.*sqrt(exten(7))
14799  ! dav2(idav,18): y-extension (mm)
14800  ! dav2(idav,19): yp-extension (mrad)
14801  ! dav2(idav,20): coefficient of correlation in the plane (y, yp)
14802  dav2(idav, 20) = 0.
14803  if (exten(6)/=0. .and. exten(7)/=0.) dav2(idav, 20) = exten(9)/sqrt(exten(6)*exten(7))
14804  dav2(idav, 18) = qditay*10.
14805  dav2(idav, 19) = qdianp
14806  ! dav2(idav,21) : Emittance(norm) in y-yp (mm*mrad)
14807  dav2(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
14808  ! dav1(idav,22) : Emittance(non norm) in y-yp (mm*mrad)
14809  dav2(idav, 22) = suryph*10./pi
14810  ! next card to indicate chase
14811  dav1(idav, 26) = 1.
14812  do i = 1, ngood
14813  ichas(i) = 1
14814  end do
14815  end if
14816  ! print energy, boro etc for each charge state in long
14817  if (ncstat>1) then
14818  write (16, '(1x,a4)') 'EMIT'
14819  do k = 1, ncstat
14820  ndp(k) = 0
14821  do j = 2, 7
14822  foo(k, j) = 0.
14823  end do
14824  end do
14825  do i = 1, imax
14826  if (f(8,i)==1) then
14827  do k = 1, ncstat
14828  if (f(9,i)==cstat(k)) then
14829  ndp(k) = ndp(k) + 1
14830  do j = 2, 7
14831  foo(k, j) = foo(k, j) + f(j, i)
14832  end do
14833  end if
14834  end do
14835  end if
14836  end do
14837  do k = 1, ncstat
14838  if (ndp(k)/=0) then
14839  do j = 2, 7
14840  foo(k, j) = foo(k, j)/float(ndp(k))
14841  end do
14842  end if
14843  end do
14844  write (16, *) ' Q Particles beta Wcog(MeV)', &
14845  ' Wcog(MeV/u) Pcog(kG.cm) TOF(deg) TOF(sec) ', ' X_avg(cm) Xp_avg(mrad) ', &
14846  'Y_avg(cm) Yp_avg(mrad)'
14847  do k = 1, ncstat
14848  if (ndp(k)/=0) then
14849  gref = foo(k, 7)/xmat
14850  bref = sqrt(1.-1./(gref*gref))
14851  xe = (gref-1.)*xmat
14852  ! magnetic rigidity
14853  bor = 3.3356*xmat*bref*gref/cstat(k)
14854  write (16, '(2x,f5.2,3x,I5,5x,F9.7, 5(1x,E12.5),1x,4(F12.5,2x))') cstat(k), &
14855  ndp(k), bref, xe, xe/atm, bor, foo(k, 6)*180.*fh/pi, foo(k, 6), foo(k, 2), foo(k, 3), foo(k, 4), foo(k, 5)
14856  else
14857  write (16, '(2x,f5.2,3x,I5)') cstat(k), ndp(k)
14858  end if
14859  end do
14860  write (16, *)
14861  end if
14862  return
14863  end subroutine emiprt
14864  ! *******************************************************************
14865  ! SUBROUTINE emit3d
14866  ! get beam data following RDBEAM for TRACE3D file
14867  ! *******************************************************************
14868  subroutine emit3d
14869  implicit real *8(a-h, o-z)
14870  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14871  common /dyn/tref, vref
14872  common /faisc/f(10, iptsz), imax, ngood
14873  common /qmoyen/qmoy
14874  common /etcom/cog(8), exten(17), fd(iptsz)
14875  common /consta/vl, pi, xmat, rpel, qst
14876  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
14877  common /trace3e/tracebi(6), traceei(3)
14878  character *128 trace3h, trace3t, tif
14879 
14880  iarg = 1
14881  call cdg(iarg)
14882  call ext2d(1)
14883  ! --- qdisp : average dispersion (MeV)
14884  ! --- sqmdv: emittance (MeV*rad)
14885  qdisp = 2.*sqrt(exten(1))
14886  qmdv = exten(1)*exten(3) - exten(2)*exten(2)
14887  sqmdv = 4.*pi*sqrt(qmdv)
14888  ! --- qdp : average extension in phase (rad)
14889  qdp = 2.*sqrt(exten(3))
14890  ! --- cor12: coefficient of correlation in (dE, dPHI)
14891  cor12 = exten(2)/sqrt(exten(1)*exten(3))
14892  ! ---- statistics in x-xp and y-yp
14893  trqtx = exten(4)*exten(5) - exten(8)*exten(8)
14894  trqpy = exten(6)*exten(7) - exten(9)*exten(9)
14895  surxth = 4.*pi*sqrt(trqtx)
14896  suryph = 4.*pi*sqrt(trqpy)
14897  qditax = 2.*sqrt(exten(4))
14898  qdiant = 2.*sqrt(exten(5))
14899  qditay = 2.*sqrt(exten(6))
14900  qdianp = 2.*sqrt(exten(7))
14901  ! trace3d
14902  ! x-xp (mm*mrad)
14903  emitx = surxth*10./pi
14904  sgn = 1.
14905  if (exten(4)/=0. .and. exten(5)/=0.) sgn = exten(8)/sqrt(exten(4)*exten(5))
14906  betax = qditax*10.*qditax*10./emitx
14907  gamx = qdiant*qdiant/emitx
14908  alphax = sqrt(betax*gamx-1.)
14909  if (sgn>0.) alphax = -alphax
14910  ! y-yp (mm*mrad)
14911  emity = suryph*10./pi
14912  sgn = 1.
14913  if (exten(6)/=0. .and. exten(7)/=0.) sgn = exten(9)/sqrt(exten(6)*exten(7))
14914  betay = qditay*10.*qditay*10./emity
14915  gamy = qdianp*qdianp/emity
14916  alphay = sqrt(betay*gamy-1.)
14917  if (sgn>0.) alphay = -alphay
14918  ! z-zp (keV*deg)
14919  emitz = sqmdv/pi*1000.*(180./pi)
14920  betaz = qdp*180./pi*qdp*180./pi/emitz
14921  gamz = qdisp*1000.*qdisp*1000./emitz
14922  alphaz = sqrt(betaz*gamz-1.)
14923  if (cor12>0.) alphaz = -alphaz
14924  ! store parameters for trace3d
14925  tracebi(1) = alphax
14926  tracebi(2) = betax
14927  tracebi(3) = alphay
14928  tracebi(4) = betay
14929  tracebi(5) = alphaz
14930  tracebi(6) = betaz
14931  traceei(1) = emitx
14932  traceei(2) = emity
14933  traceei(3) = emitz
14934  return
14935  end subroutine emit3d
14936  ! *******************************************************************
14937  ! SUBROUTINE statis
14938  ! statitics of the 6-d ellipsoid (for print)
14939  ! calls EXT2D:
14940  ! exten(1) : Sum( dE(i)*dE(i) ) MeV*MeV
14941  ! exten(2) : Sum( dE(i)*dPHase(i) ) MeV*rad
14942  ! exten(3) : Sum( dPHase(i)*dPHase(i) ) rad*rad
14943  ! exten(4) : Sum( x(i)*x(i) ) cm*cm
14944  ! exten(5) : Sum( xp(i)*xp(i) ) mrad*mrad
14945  ! exten(6) : Sum( y(i)*y(i) ) cm*cm
14946  ! exten(7) : Sum( yp(i)*yp(i) ) mrad*mrad
14947  ! exten(8) : Sum( x(i)*xp(i) ) cm*mrad
14948  ! exten(9) : Sum( y(i)*yp(i) ) cm*mrad
14949  ! *******************************************************************
14950  subroutine statis
14951  implicit real *8(a-h, o-z)
14952  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
14953  common /dyn/tref, vref
14954  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
14955  common /faisc/f(10, iptsz), imax, ngood
14956  common /qmoyen/qmoy
14957  common /consta/vl, pi, xmat, rpel, qst
14958  common /stis/surxth, suryph, enedep, ecogde, testca
14959  common /etcom/cog(8), exten(17), fd(iptsz)
14960  ! EXT2D looks for average extensions squared and returns them in EXTEN
14961  iarg = 1
14962  call cdg(iarg)
14963  encog = cog(1)
14964  gcog = encog/xmat
14965  bcog = sqrt(1.-1./(gcog*gcog))
14966  tcog = cog(3)
14967  bref = vref/vl
14968  gref = 1./sqrt(1.-bref*bref)
14969  enref = xmat*gref
14970  ccgp = (tcog-tref)*fh*180./pi
14971  ccgd = encog - enref
14972  do i = 1, ngood
14973  gpai = f(7, i)/xmat
14974  bpai = sqrt(1.-1./(gpai*gpai))
14975  fd(i) = bpai/bcog*gpai/gcog
14976  end do
14977  call ext2d(1)
14978  testca = exten(1)*exten(2)*exten(3)
14979  if (abs(testca)>1.e-40) then
14980  qdisp = 2.*sqrt(exten(1))
14981  qmd = exten(1)*exten(3) - exten(2)*exten(2)
14982  surm = 4.*pi*sqrt(qmd)*180./pi
14983  qdp = 2.*sqrt(exten(3))
14984  cor12 = exten(2)/sqrt(exten(1)*exten(3))
14985  ! sup PENT12=SQRT(exten(1)/exten(3))/COR12
14986  ! sup PENT21=SQRT(exten(1)/exten(3))*COR12
14987  qdpde = qdp*180./pi
14988  else
14989  qdisp = 0.
14990  qmd = 0.
14991  surm = 0.
14992  qdp = 0.
14993  cor12 = 0.
14994  pent12 = 0.
14995  pent21 = 0.
14996  qdpde = 0.
14997  end if
14998  trqtx = exten(4)*exten(5) - exten(8)*exten(8)
14999  trqpy = exten(6)*exten(7) - exten(9)*exten(9)
15000  qditax = 2.*sqrt(exten(4))
15001  qdiant = 2.*sqrt(exten(5))
15002  qditay = 2.*sqrt(exten(6))
15003  qdianp = 2.*sqrt(exten(7))
15004  surxth = 4.*pi*sqrt(trqtx)
15005  suryph = 4.*pi*sqrt(trqpy)
15006  sqmdv = 4.*pi*sqrt(qmd)
15007  write (16, 52) imax, ngood
15008 52 format (4x, ' TOTAL NUMBER OF PARTICLES :', i5, ' NUMBER OF PARTICLES CONSIDERED :', i6, /)
15009  write (16, 1557)
15010 1557 format (5x, ' *** TRANSVERSE AND LONGITUDINAL STATISTICS')
15011  write (16, 1553) cog(4), cog(5)
15012 1553 format (4x, ' COG COORD X : ', e12.5, ' CM XP :', e12.5, ' MRD')
15013  write (16, 1556) cog(6), cog(7)
15014 1556 format (4x, ' COG COORD Y : ', e12.5, ' CM YP :', e12.5, ' MRD')
15015  write (16, 14) ccgp, ccgd
15016 14 format (4x, ' COG COORD dPHI: ', e12.5, ' deg dW :', e12.5, ' MeV')
15017  write (16, 1552) qditax, qdiant, surxth/pi
15018 1552 format (4x, ' X :', e12.5, ' CM XP :', e12.5, ' MRD EMITTANCE :', e15.8, ' CM.MRD')
15019  write (16, 1555) qditay, qdianp, suryph/pi
15020 1555 format (4x, ' Y :', e12.5, ' CM YP :', e12.5, ' MRD EMITTANCE :', e15.8, ' CM.MRD')
15021  write (16, 154) qdpde, qdisp, sqmdv*180./(pi*pi)
15022 154 format (4x, ' dPHI : ', f7.3, ' deg dW :', 3x, f7.3, 3x, 'MeV EMITTANCE :', e15.8, ' MeV.deg', /)
15023  ! sup write(16,*) ' *** ellips (dE,dPHI) '
15024  ! sup write(16,19) surm,qdp,qdisp,cor12
15025  ! sup19 format(' area: ',e12.5,' MeV*deg half phase extent: ',e12.5,
15026  ! sup * ' deg half energy extend: ',e12.5,' MeV',/,
15027  ! sup * ' correlation coef: ',e12.5)
15028  ! sup *
15029  return
15030  end subroutine statis
15031  ! *******************************************************************
15032  ! SUBROUTINE tiltbm(icg)
15033  ! tilt and shift of the beam with respect to the cog
15034  ! TIPHA : Shift on the phase axis(DEG)
15035  ! TIX : Shift in the x-direction (CM)
15036  ! TIY : Shift in the y-direction (CM)
15037  ! SHIFW : Change the energy position of the c.o.g.(MeV)
15038  ! SHIFP : Change the phase position of the c.o.g.(deg)
15039  ! DTIPH : Change the position of the phase (radian)
15040  ! ICG : = 0 VREF and TREF are the ones of sync. particle
15041  ! ICG :. NE. 0 VREF ET TREF are the ones of the c. of g.
15042  ! *******************************************************************
15043  subroutine tiltbm(icg)
15044  implicit real *8(a-h, o-z)
15045  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15046  common /consta/vl, pi, xmat, rpel, qst
15047  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
15048  common /tilt/tipha, tix, tiy, shifw, shifp
15049  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15050  common /faisc/f(10, iptsz), imax, ngood
15051  common /objet/fo(9, iptsz), imaxo
15052  common /qmoyen/qmoy
15053  common /rigid/boro
15054  common /dyn/tref, vref
15055  common /stis/suryth, surzph, enedep, ecogde, testca
15056  common /newtlt/twissa(3), itwiss
15057  common /histo/centre(6)
15058  common /shif/dtiph, shift
15059  common /tof/tofini
15060  logical shift
15061  common /tapes/in, ifile, meta
15062  common /etcom/cog(8), exten(17), fd(iptsz)
15063 
15064  write (16, 1) tipha, tix, tiy, shifw, shifp
15065 1 format (' Shift the position of the bunch', /, ' in the z-direction :', e12.5, ' DEG', /, &
15066  ' in the x-direction :', e12.5, ' CM ', /, ' in the y-direction :', e12.5, ' CM ', /, &
15067  ' shift the energy of the cog with :', e12.5, ' MeV', /, ' shift the phase of the cog with :', e12.5, &
15068  ' deg', /)
15069  tipha = tipha*pi/180.
15070  shifp = shifp*pi/180.
15071  deg = fh*180./pi
15072  iarg = 1
15073  call cdg(iarg)
15074  encog = cog(1)
15075  tcog = cog(3)
15076  gcog = encog/xmat
15077  bcog = sqrt(1.-1./(gcog*gcog))
15078  ! --- this routine is call by the routine ENTRE with icg = 1
15079  ! the reference particle is the cog of the bunch
15080  if (icg/=0) then
15081  tref = tcog
15082  vref = vl*bcog
15083  vcour = vref
15084  gcour = gcog
15085  bcour = bcog
15086  write (16, *) '*** Before tilt and shift '
15087  write (16, 24) bcog, tref, tref*deg, encog - xmat
15088 24 format (2x, '*** the reference particle is the cog:', /, ' REF AND COG: BETA :', e12.5, 2x, 'TOF :', e12.5, &
15089  ' SEC OR: ', e12.5, ' deg', 2x, ' ENERGY :', e12.5, ' MeV', /)
15090  end if
15091  if (icg==0) then
15092  vcour = vl*bcog
15093  bcour = bcog
15094  gcour = gcog
15095  bvref = vref/vl
15096  gamref = 1./sqrt(1.-bvref*bvref)
15097  wvref = (gamref-1.)*xmat
15098  write (16, *) '*** Before tilt and shift '
15099  write (16, *) ' the reference particle and cog are distinct'
15100  write (16, 16) bvref, tref, tref*deg, wvref, bcog, tcog, tcog*deg, encog - xmat
15101 16 format (2x, ' REF: BETA ', e12.5, ' T.O.F. ', e12.5, ' SEC OR ', e12.5, ' DG', ' ENERGY ', e12.5, ' MeV', //, &
15102  2x, ' COG: BETA ', e12.5, ' T.O.F. ', e12.5, ' SEC OR ', e12.5, ' DG', ' ENERGY ', e12.5, ' MeV', /)
15103  end if
15104  do i = 1, ngood
15105  gapi = f(7, i)/xmat
15106  bepi = sqrt(1.-1./(gapi*gapi))
15107  fd(i) = bepi/bcour*gapi/gcour
15108  end do
15109  call ext2(1)
15110  ! shift of the ellipse in the longitudinal plane with regard to the cog (TILT)
15111  ! the slip of phase is : TIPHA
15112  ! the ellipsoid generated by GEBEAM and INPUT is upright
15113  ! qdispw=dispersion in energy
15114  qdispw = 2.*sqrt(exten(10))
15115  encrt = encog + qdispw
15116  gamcrt = encrt/xmat
15117  bcrt = sqrt(1.-1./(gamcrt*gamcrt))
15118  vcrt = bcrt*vl
15119  delv = vcrt - vcour
15120  ! shift of the ellipse in the transverse planes with regard to the cog
15121  ! DELTH ET DELPH: slips in xp and yp (mrd)
15122  ! horizontal plane
15123  delxp = 2.*sqrt(exten(5))
15124  ! vertical plane
15125  delyp = 2.*sqrt(exten(7))
15126  write (16, 22) qdispw, delxp, delyp
15127 22 format (' half size in energy ', e12.5, ' MeV', /, ' half size in xp ', e12.5, ' mrd', /, ' half size in yp ', &
15128  e12.5, ' mrd')
15129  ! Shift of the ellipses in the phase spaces
15130  tcrt = 0.
15131  do i = 1, ngood
15132  gapi = f(7, i)/xmat
15133  bpai = sqrt(1.-1./(gapi*gapi))
15134  vpai = vl*bpai
15135  dv = (vpai-vcour)*tipha/(delv*fh)
15136  f(6, i) = f(6, i) - dv
15137  tcrt = tcrt + f(6, i)
15138  dlx = 0.
15139  dly = 0.
15140  if (delxp/=0.) dlx = f(3, i)*tix/delxp
15141  if (delyp/=0.) dly = f(5, i)*tiy/delyp
15142  f(2, i) = f(2, i) + dlx
15143  f(4, i) = f(4, i) + dly
15144  end do
15145  tcrt = tcrt/float(ngood)
15146  dtiph = 0.
15147  if (shifw/=0. .or. shifp/=0.) then
15148  shtref = shifp/fh
15149  enshift = encog + shifw
15150  gshift = enshift/xmat
15151  bshift = sqrt(1.-1./(gshift*gshift))
15152  eshift = enshift - xmat
15153  vshift = vl*bshift
15154  tshift = tcrt + shtref
15155  deltav = vshift - vcour
15156  deltat = tshift - tcog
15157  end if
15158  if (shifw==0. .and. shifp==0.) then
15159  enshift = encog
15160  eshift = enshift - xmat
15161  gshift = gcour
15162  vshift = vcour
15163  bshift = vshift/vl
15164  tshift = tcrt
15165  shtref = 0.
15166  deltav = 0.
15167  deltat = 0.
15168  end if
15169  do i = 1, ngood
15170  f(7, i) = f(7, i) + shifw
15171  gpai = f(7, i)/xmat
15172  bpai = sqrt(1.-1./(gpai*gpai))
15173  f(6, i) = f(6, i) + shtref
15174  vapi = vl*bpai
15175  end do
15176  if (itwiss==1) tref = tref + tofini
15177  write (16, *) ' ***After tilt and shift '
15178  bvref = vref/vl
15179  gamref = 1./sqrt(1.-bvref*bvref)
15180  wvref = (gamref-1.)*xmat
15181  write (16, 16) bvref, tref, tref*deg, wvref, bshift, tshift, tshift*deg, eshift
15182  do i = 1, ngood
15183  fo(7, i) = f(7, i)
15184  fo(2, i) = f(2, i)
15185  fo(3, i) = f(3, i)
15186  fo(4, i) = f(4, i)
15187  fo(5, i) = f(5, i)
15188  fo(6, i) = f(6, i)
15189  end do
15190  if (itwiss/=1) then
15191  dum = 0.
15192  write (11, *) ngood, dum, fh/(2000000.*pi)
15193  do i = 1, ngood
15194  f(2, i) = f(2, i) + centre(2)
15195  f(3, i) = f(3, i) + centre(3)
15196  f(4, i) = f(4, i) + centre(4)
15197  f(5, i) = f(5, i) + centre(5)
15198  f(6, i) = f(6, i) + centre(6)
15199  f(7, i) = f(7, i) + centre(1)
15200  etphas = fh*(f(6,i)-tcog)
15201  ! option etener=f(7,i)-encog
15202  etener = f(7, i) - xmat
15203  write (11, 777) f(2, i), f(3, i)/1000., f(4, i), f(5, i)/1000., etphas, etener
15204  end do
15205 777 format (6(f13.8,1x))
15206  end if
15207  ! ENVELOPE
15208  call stapl(davtot*10.)
15209  return
15210  end subroutine tiltbm
15211  ! *******************************************************************
15212  ! SUBROUTINE tiltbm_bis(icg)
15213  ! Change the positions of the beam in the phase planes
15214  ! TIPHA : Shift with regard to the phase axis(DEG)
15215  ! TIX : Shift in the x-direction (CM)
15216  ! TIY : Shift in the y-direction (CM)
15217  ! SHIFW : Change the energy position of the c.o.g.(MeV)
15218  ! SHIFP : Change the phase position of the c.o.g.(deg)
15219  ! DTIPH : Change the position of the phase (radian)
15220  ! ICG : = 0 VREF and TREF are the ones of sync. particle
15221  ! ICG :. NE. 0 VREF ET TREF are the ones of the c. of g.
15222  ! *******************************************************************
15223  subroutine tiltbm_bis(icg)
15224  implicit real *8(a-h, o-z)
15225  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15226  common /consta/vl, pi, xmat, rpel, qst
15227  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
15228  common /tilt/tipha, tix, tiy, shifw, shifp
15229  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15230  common /faisc/f(10, iptsz), imax, ngood
15231  common /objet/fo(9, iptsz), imaxo
15232  common /qmoyen/qmoy
15233  common /rigid/boro
15234  common /dyn/tref, vref
15235  common /stis/suryth, surzph, enedep, ecogde, testca
15236  common /newtlt/twissa(3), itwiss
15237  common /histo/centre(6)
15238  common /shif/dtiph, shift
15239  ! omment common/tof/tofini
15240  logical shift
15241  common /tapes/in, ifile, meta
15242  common /etcom/cog(8), exten(17), fd(iptsz)
15243 
15244  write (16, 1) tipha, tix, tiy, shifw, shifp
15245 1 format (' shift the position around the c.o.g. of the bunch', /, ' with regard to the phase axis :', e12.5, &
15246  ' DEG', /, ' in the x-direction :', e12.5, ' CM ', /, ' in the y-direction :', &
15247  e12.5, ' CM ', /, ' Change of energy position of the c.o.g. :', e12.5, ' MEV', /, &
15248  ' Change of phase position of the c.o.g. :', e12.5, ' DEG', /)
15249  shtref = 0.
15250  tipha = tipha*pi/180.
15251  shifp = shifp*pi/180.
15252  deg = fh*180./pi
15253  iarg = 1
15254  call cdg(iarg)
15255  encog = cog(1)
15256  tcog = cog(3)
15257  gcog = encog/xmat
15258  bcog = sqrt(1.-1./(gcog*gcog))
15259  if (icg/=0 .and. (shifw==0. .or. shifp==0.)) then
15260  ! the reference and the cog coincide
15261  tref = tcog
15262  vref = vl*bcog
15263  vcour = vref
15264  gcour = gcog
15265  bcour = bcog
15266  write (16, *) ' Before shift '
15267  write (16, 24) vref, tref, encog - xmat
15268 24 format (2x, ' Note : reference will coincide with the cog', /, 2x, ' velocity :', e12.5, ' CM/SEC', 2x, 'tof :', &
15269  e12.5, ' SEC', /, 2x, ' ENERGY :', e12.5, ' MeV', /)
15270  else
15271  ! the reference is distinct from the cog
15272  vcour = vl*bcog
15273  bcour = bcog
15274  gcour = gcog
15275  bvref = vref/vl
15276  gamref = 1./sqrt(1.-bvref*bvref)
15277  wvref = (gamref-1.)*xmat
15278  write (16, *) ' Before shift '
15279  write (16, 16) vref, tref, tref*deg, wvref, vcour, tcog, tcog*deg, encog - xmat
15280  end if
15281  do i = 1, ngood
15282  gapi = f(7, i)/xmat
15283  bepi = sqrt(1.-1./(gapi*gapi))
15284  fd(i) = bepi/bcour*gapi/gcour
15285  end do
15286  call ext2(1)
15287  ! shift of the ellipse in the longitudinal plane with regard to the cog (TILT)
15288  ! the slip of phase is : TIPHA
15289  ! the elipsoid generated from MONTE end ENTRE is upright
15290  ! qdispw=dispersion in energy
15291  qdispw = 2.*sqrt(exten(10))
15292  encrt = encog + qdispw
15293  gamcrt = encrt/xmat
15294  bcrt = sqrt(1.-1./(gamcrt*gamcrt))
15295  vcrt = bcrt*vl
15296  delv = vcrt - vcour
15297  ! shift of the ellipse in the transverse planes with regard to the cog
15298  ! DELTH ET DELPH: slips in xp and yp (MRD)
15299  ! horizontal plane
15300  delxp = 2.*sqrt(exten(5))
15301  ! vertical plane
15302  delyp = 2.*sqrt(exten(7))
15303  write (16, 22) qdispw, delxp, delyp
15304 22 format (' half size in energy ', e12.5, ' MeV', /, ' half size in xp ', e12.5, ' mrd', /, ' half size in yp ', &
15305  e12.5, ' mrd')
15306  ! Shift of the ellipses in the phase spaces
15307  tcrt = 0.
15308  do i = 1, ngood
15309  gapi = f(7, i)/xmat
15310  bpai = sqrt(1.-1./(gapi*gapi))
15311  vpai = vl*bpai
15312  dv = (vpai-vcour)*tipha/(delv*fh)
15313  f(6, i) = f(6, i) - dv
15314  tcrt = tcrt + f(6, i)
15315  dlx = 0.
15316  dly = 0.
15317  if (delxp/=0.) dlx = f(3, i)*tix/delxp
15318  if (delyp/=0.) dly = f(5, i)*tiy/delyp
15319  f(2, i) = f(2, i) + dlx
15320  f(4, i) = f(4, i) + dly
15321  end do
15322  tcrt = tcrt/float(ngood)
15323  dtiph = 0.
15324  ! shift=.true.: The reference and COG are independent
15325  ! shift=.false. The reference and COG are the same
15326  if (shifw/=0. .or. shifp/=0.) then
15327  shift = .true.
15328  shtref = shifp/fh
15329  enshift = encog + shifw
15330  gshift = enshift/xmat
15331  bshift = sqrt(1.-1./(gshift*gshift))
15332  eshift = enshift - xmat
15333  vshift = vl*bshift
15334  tshift = tcrt + shtref
15335  else
15336  shift = .false.
15337  enshift = encog
15338  eshift = enshift - xmat
15339  gshift = gcour
15340  vshift = vcour
15341  tshift = tcrt
15342  end if
15343  if (icg==0) then
15344  deltav = vshift - vcour
15345  deltat = tshift - tcog
15346  else
15347  deltav = 0.
15348  deltat = 0.
15349  shifw = 0.
15350  shtref = 0.
15351  end if
15352  write (16, *) 'tofini,tcrt=', tofini, tcrt, tcrt*deg
15353  if (shift) then
15354  write (16, *) 'Reference and COG are independent', icg
15355  else
15356  write (16, *) 'Reference and COG coincide', icg
15357  end if
15358  do i = 1, ngood
15359  f(7, i) = f(7, i) + shifw
15360  gpai = f(7, i)/xmat
15361  bpai = sqrt(1.-1./(gpai*gpai))
15362  f(6, i) = f(6, i) + shtref
15363  vapi = vl*bpai
15364  end do
15365  if (itwiss==1) tref = tref + tofini
15366  write (16, *) ' After shift '
15367  bvref = vref/vl
15368  gamref = 1./sqrt(1.-bvref*bvref)
15369  wvref = (gamref-1.)*xmat
15370  write (16, 16) vref, tref, tref*deg, wvref, vshift, tshift, tshift*deg, eshift
15371 16 format (2x, ' REFERENCE: VELOCITY :', e12.5, ' CM/SEC, T.O.F. :', e12.5, ' SEC OR ', e12.5, ' DG', /, 3x, &
15372  ' ENERGY : ', e12.5, ' MeV', /, 2x, ' C.O.G.: VELOCITY :', e12.5, ' CM/SEC, T.O.F. :', e12.5, ' SEC OR ', &
15373  e12.5, ' DG', /, 3x, ' ENERGY : ', e12.5, ' MeV', //)
15374  bpai = 0.
15375  do i = 1, ngood
15376  fo(7, i) = f(7, i)
15377  fo(2, i) = f(2, i)
15378  fo(3, i) = f(3, i)
15379  fo(4, i) = f(4, i)
15380  fo(5, i) = f(5, i)
15381  fo(6, i) = f(6, i)
15382  end do
15383  if (itwiss/=1) then
15384  write (11, *) ngood
15385  do i = 1, ngood
15386  f(2, i) = f(2, i) + centre(2)
15387  f(3, i) = f(3, i) + centre(3)
15388  f(4, i) = f(4, i) + centre(4)
15389  f(5, i) = f(5, i) + centre(5)
15390  f(6, i) = f(6, i) + centre(6)
15391  f(7, i) = f(7, i) + centre(1)
15392  etphas = fh*(f(6,i)-tcog)
15393  ! option etener=f(7,i)-encog
15394  etener = f(7, i) - xmat
15395  write (11, 777) f(2, i), f(3, i), f(4, i), f(5, i), etphas, etener
15396  end do
15397 777 format (6(f13.8,1x))
15398  end if
15399  ! ENVELOPE
15400  call stapl(davtot*10.)
15401  return
15402  end subroutine tiltbm_bis
15403  ! *******************************************************************
15404  ! SUBROUTINE accept
15405  ! computes a physical beam acceptance at the entrance of the machine
15406  ! *******************************************************************
15407  subroutine accept
15408  implicit real *8(a-h, o-z)
15409  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15410  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15411  common /tapes/in, ifile, meta
15412  common /faisc/f(10, iptsz), imax, ngood
15413  common /etcom/cog(8), exten(17), fd(iptsz)
15414  common /dyn/tref, vref
15415  common /dyni/vrefi, trefi, fhinit, acpt
15416  common /qmoyen/qmoy
15417  common /objet/fo(9, iptsz), imaxo
15418  common /consta/vl, pi, xmat, rpel, qst
15419  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
15420  dimension back(9, iptsz)
15421  logical chasit, acpt
15422  common /mcs/imcs, ncstat, cstat(20)
15423  ! make statistics on initial beam using IEX at the point where
15424  ! the ACCEPT card has been placed
15425  write (16, *)
15426  write (16, *) 'Physical acceptance has:'
15427  write (16, *) imaxo, ' particles at origin'
15428  iprint = 1
15429  savfh = fh
15430  satref = tref
15431  savref = vref
15432  ! recall initial frequency
15433  fh = fhinit
15434  tref = trefi
15435  vref = vrefi
15436  ! save current beam
15437  do i = 1, 9
15438  do j = 1, ngood
15439  back(i, j) = f(i, j)
15440  end do
15441  end do
15442  ! original particle number is in f(1,j)
15443  ! F (I,8): =1 the particle is good, =0 the particle is lost
15444  ! recuperate original particle numbers and their coordinates
15445  ! next loop for graphics and file of good particles
15446  do j = 1, imax
15447  tprt = fh*fo(6, j)
15448  eprt = fo(7, j) - xmat
15449  f2 = fo(2, j)
15450  f3 = fo(3, j)/1000.
15451  f4 = fo(4, j)
15452  f5 = fo(5, j)/1000.
15453  nold = int(f(1,j))
15454  end do
15455  open (23, file='input_kept.dst', status='unknown')
15456  dummy = 0.
15457  write (23, *) ngood, dummy, fh/(2000000.*pi)
15458  do j = 1, ngood
15459  nold = int(f(1,j))
15460  do jj = 1, 9
15461  f(jj, j) = fo(jj, nold)
15462  end do
15463  tprt = fh*f(6, j)
15464  eprt = f(7, j) - xmat
15465  f2 = f(2, j)
15466  f3 = f(3, j)
15467  f4 = f(4, j)
15468  f5 = f(5, j)
15469  if (ncstat>1) then
15470  write (23, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, j)
15471  else
15472  write (23, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
15473  end if
15474  end do
15475  close (23)
15476  ! now make graphics
15477  write (16, *) 'Starting good particles graphics for ACCEPT card'
15478  igrprm = 0
15479  call ytzp
15480  ! print out beam statistics
15481  call emiprt(0)
15482  ! next loop for graphics and file of lost particles
15483  open (23, file='input_lost.dst', status='unknown')
15484  dummy = 0.
15485  write (23, *) imax - ngood, dummy, fh/(2000000.*pi)
15486  j = 1
15487  ngd = ngood
15488  do k = ngood + 1, imax
15489  nold = int(f(1,k))
15490  do jj = 1, 9
15491  f(jj, j) = fo(jj, nold)
15492  end do
15493  tprt = fh*f(6, j)
15494  eprt = f(7, j) - xmat
15495  f2 = f(2, j)
15496  f3 = f(3, j)
15497  f4 = f(4, j)
15498  f5 = f(5, j)
15499  if (ncstat>1) then
15500  write (23, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, j)
15501  else
15502  write (23, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
15503  end if
15504  j = j + 1
15505  end do
15506  ngood = imax - ngood
15507 100 format (6(f15.8,1x))
15508 101 format (7(f15.8,1x))
15509  close (23)
15510  ! now make graphics
15511  write (16, *) 'Starting lost particles graphics for ACCEPT card'
15512  igrprm = 0
15513  call ytzp
15514  ! print out beam statistics
15515  call emiprt(0)
15516  ! recall original coordinates
15517  ngood = ngd
15518  do i = 1, 9
15519  do j = 1, ngood
15520  f(i, j) = back(i, j)
15521  end do
15522  end do
15523  tref = satref
15524  vref = savref
15525  fh = savfh
15526  return
15527  end subroutine accept
15528  ! *******************************************************************
15529  ! SUBROUTINE ytzp
15530  ! STORAGE OF PARTICLE COORDINATES FOR PLOTS
15531  ! *******************************************************************
15532  subroutine ytzp
15533  implicit real *8(a-h, o-z)
15534  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15535  character *80 text, patitl
15536  common /consta/vl, pi, xmat, rpel, qst
15537  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15538  common /faisc/f(10, iptsz), imax, ngood
15539  common /stis/suryth, surzph, enedep, ecogde, testca
15540  common /fene/wdisp, wphas, wx, wy, rlim, ifw
15541  common /dyn/tref, vref
15542  common /tapes/in, ifile, meta
15543  common /etcom/cog(8), exten(17), fd(iptsz)
15544  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
15545  common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
15546  common /mcs/imcs, ncstat, cstat(20)
15547  common /zones/frms(6), nzone
15548  logical chasit
15549  dimension oldcog(7), slim(4, 2)
15550  dimension xx(iptsz), yy(iptsz), cs(iptsz)
15551 
15552  satref = tref
15553  savref = vref
15554  init = 0
15555  call area(init)
15556  if (igrprm==0) then
15557  ! READ GRAPH TITLE
15558  read (in, 20) text
15559 20 format (a)
15560  ! idwdp=0 cog=ref in ZZ' plot (for instance for Alvarez structure)
15561  ! idwdp=1 cog<>ref in ZZ' plot (for instance for IH structrure)
15562  read (in, *) idwdp, rmsmtp
15563  ! READ GRAPH LIMITS INTO GLIM(J,K), J=GRAPH NUMBER
15564  ! K=1 HOR. LIMIT , K=2 VERT. LIMIT
15565  read (in, *)((glim(j,k),k=1,2), j=1, 4)
15566  end if
15567  if (igrprm==1) then
15568  text = patitl
15569  end if
15570  if (igrprm==2) then
15571  text = patitl
15572  ! save limits in GLIM(j,k)
15573  do j = 1, 4
15574  do k = 1, 2
15575  slim(j, k) = glim(j, k)
15576  glim(j, k) = glim1(j, k)
15577  end do
15578  end do
15579  end if
15580  if (igrprm==3) then
15581  text = patitl
15582  ! save limits in GLIM(j,k)
15583  do j = 1, 4
15584  do k = 1, 2
15585  slim(j, k) = glim(j, k)
15586  glim(j, k) = glim2(j, k)
15587  end do
15588  end do
15589  end if
15590  do i = 1, ngood
15591  ichas(i) = 1
15592  end do
15593  iarg = 1
15594  call cdg(iarg)
15595  encog = cog(1)
15596  gcog = encog/xmat
15597  bcog = sqrt(1.-1./(gcog*gcog))
15598  tcog = cog(3)
15599  oldcog(1) = cog(4)
15600  oldcog(2) = cog(5)
15601  oldcog(3) = cog(6)
15602  oldcog(4) = cog(7)
15603  oldcog(5) = cog(3)
15604  oldcog(6) = cog(8)
15605  oldcog(7) = cog(1)
15606  enprt = encog - xmat
15607  teps = 1.e-08
15608  rmssz = sqrt(rmsmtp)
15609  iarg = 1
15610  call ext2(iarg)
15611  qdisp = rmssz*sqrt(exten(1))
15612  qmd = exten(1)*exten(3) - exten(2)*exten(2)
15613  qmdw = exten(10)*exten(3) - exten(11)*exten(11)
15614  surm = rmsmtp*180.*sqrt(qmd)
15615  qdp = rmssz*sqrt(exten(3))
15616  cor12 = exten(2)/sqrt(exten(1)*exten(3))
15617  pent12 = sqrt(exten(1)/exten(3))/cor12
15618  pent21 = sqrt(exten(1)/exten(3))*cor12
15619  qdpde = qdp*180./pi
15620  trqty = exten(4)*exten(5) - exten(8)*exten(8)
15621  trqpz = exten(6)*exten(7) - exten(9)*exten(9)
15622  suryth = rmsmtp*pi*sqrt(trqty)
15623  surzph = rmsmtp*pi*sqrt(trqpz)
15624  qditay = rmssz*sqrt(exten(4))
15625  qdiant = rmssz*sqrt(exten(5))
15626  qdita = rmssz*sqrt(exten(6))
15627  qdianp = rmssz*sqrt(exten(7))
15628  write (16, *) ' *** PLOT Ellips for ', rmsmtp, ' RMS'
15629  write (16, '(a)') text
15630  write (16, 1557) imax, ngood
15631 1557 format (1x, ' *** GRAPH, TOTAL NUMBER OF PARTICLES : ', i6, ' PARTICLES KEPT : ', i6, //, &
15632  ' *** HORIZONTAL phase plane ', /)
15633  write (16, 1553) cog(4), cog(5)
15634 1553 format (4x, ' C.O.G. :', 5x, ' X : ', e12.5, ' CM XP :', e12.5, ' MRD', /)
15635  if (rmsmtp>teps) then
15636  write (16, 1552) qditay, qdiant, suryth
15637 1552 format (4x, ' 1/2 EXTENSION X : ', e12.5, ' CM', /, 4x, ' 1/2 EXTENSION XP : ', e12.5, ' MRD', 4x, &
15638  ' SURFACE : ', e15.8, ' CM.MRD', /)
15639  end if
15640  write (16, 1554)
15641 1554 format (' *** VERTICAL phase plane ', /)
15642  write (16, 1556) cog(6), cog(7)
15643 1556 format (4x, ' C.O.G :', 5x, ' Y : ', e12.5, ' CM YP :', e12.5, ' MRD', /)
15644  if (rmsmtp>teps) then
15645  write (16, 1555) qdita, qdianp, surzph
15646 1555 format (4x, ' 1/2 EXTENSION Y : ', e12.5, ' CM', /, 4x, ' 1/2 EXTENSION YP : ', e12.5, ' MRD', 4x, &
15647  ' SURFACE : ', e15.8, ' CM.MRD', /)
15648  end if
15649  ! Store header and particle coordinates in binary file for
15650  ! graphics post-processor
15651 
15652  ! igrtyp is type of graph
15653  ! igrtyp=1 for ytzp emittance plots
15654  ! igrtyp=6 for ytzp emittance plots for multi-charge state beam
15655  ! igrtyp=11 for ytzp emittance plots with ZONES card
15656 
15657  igrtyp = 1
15658  if (nzone/=0) igrtyp = 11
15659  if (imcs==1) igrtyp = 6
15660  write (66, *) igrtyp
15661  if (igrtyp==6) then
15662  write (66, *) ncstat
15663  write (66, *)(cstat(j), j=1, ncstat)
15664  end if
15665  if (igrtyp==11) then
15666  write (66, *) nzone
15667  write (66, *)(frms(j), j=2, nzone), ' 0.'
15668  end if
15669  write (66, *) text
15670  xx(1) = glim(1, 1)
15671  yy(1) = glim(1, 2)
15672  write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15673  ! first store ellips coordinates XX'
15674  step = qdiant/50.
15675  tta = exten(5)
15676  do i = 1, 101
15677  xii = -qdiant + step*float(i-1)
15678  yy(i) = xii + cog(5)
15679  yy(202-i) = yy(i)
15680  ttb = exten(8)*xii
15681  ttc = exten(4)*xii**2 - trqty*rmsmtp
15682  ttcb = ttb**2 - ttc*tta
15683  if (ttcb<=0.) ttcb = 0.
15684  if (tta==0.) then
15685  yi = 0.
15686  yii = 0.
15687  else
15688  quot = ttcb/tta**2
15689  yi = ttb/tta - sqrt(quot)
15690  yii = ttb/tta + sqrt(quot)
15691  end if
15692  xx(i) = yi + cog(4)
15693  xx(202-i) = yii + cog(4)
15694  end do
15695  do i = 1, 201
15696  write (66, *) xx(i), yy(i)
15697  end do
15698  do i = 1, ngood
15699  xx(i) = f(2, i)
15700  yy(i) = f(3, i)
15701  end do
15702  if (imcs==1) then
15703  do i = 1, ngood
15704  cs(i) = f(9, i)
15705  end do
15706  end if
15707  ! write particle coordinates to graphics file
15708  write (66, *) ngood
15709  if (imcs==0) then
15710  if (nzone==0) then
15711  do i = 1, ngood
15712  write (66, *) xx(i), yy(i)
15713  end do
15714  else
15715  do i = 1, ngood
15716  write (66, *) xx(i), yy(i), f(10, i)
15717  end do
15718  end if
15719  else
15720  do i = 1, ngood
15721  write (66, *) xx(i), yy(i), cs(i)
15722  end do
15723  end if
15724  ! YY' next
15725  xx(1) = glim(2, 1)
15726  yy(1) = glim(2, 2)
15727  write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15728  ! first write ellips coordinates
15729  step = qdianp/50.
15730  tta = exten(7)
15731  do i = 1, 101
15732  xii = -qdianp + step*float(i-1)
15733  yy(i) = xii + cog(7)
15734  yy(202-i) = yy(i)
15735  ttb = exten(9)*xii
15736  ttc = exten(6)*xii**2 - trqpz*rmsmtp
15737  ttcb = ttb**2 - ttc*tta
15738  if (ttcb<=0.) ttcb = 0.
15739  if (tta==0.) then
15740  yi = 0.
15741  yii = 0.
15742  else
15743  quot = ttcb/tta**2
15744  yi = ttb/tta - sqrt(quot)
15745  yii = ttb/tta + sqrt(quot)
15746  end if
15747  xx(i) = yi + cog(6)
15748  xx(202-i) = yii + cog(6)
15749  end do
15750  do i = 1, 201
15751  write (66, *) xx(i), yy(i)
15752  end do
15753  do i = 1, ngood
15754  xx(i) = f(4, i)
15755  yy(i) = f(5, i)
15756  end do
15757  ! write particle coordinates to graphics file
15758  write (66, *) ngood
15759  if (imcs==0) then
15760  if (nzone==0) then
15761  do i = 1, ngood
15762  write (66, *) xx(i), yy(i)
15763  end do
15764  else
15765  do i = 1, ngood
15766  write (66, *) xx(i), yy(i), f(10, i)
15767  end do
15768  end if
15769  else
15770  do i = 1, ngood
15771  write (66, *) xx(i), yy(i), cs(i)
15772  end do
15773  end if
15774 
15775  ! TRACE GRAPHE ZZ'
15776  xx(1) = glim(3, 1)
15777  yy(1) = glim(3, 2)
15778  write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15779 
15780  xx(1) = glim(4, 1)
15781  yy(1) = glim(4, 2)
15782  write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15783  ! TRACE DE L ELLIPSE DE CONCENTRATION
15784  bref = vref/vl
15785  gref = 1./sqrt(1.-bref*bref)
15786  wref = xmat*(gref-1.)
15787  gcog = 1./sqrt(1.-bcog*bcog)
15788  wcog = xmat*(gcog-1.)
15789  write (16, 22) wref, tref, wcog, tcog
15790 22 format (' *** LONGITUDINAL phase plane ', /, 6x, ' REFERENCE : ', ' ENERGY: ', e15.8, ' (MeV), TOF: ', e15.8, &
15791  ' (SEC)', /, 6x, ' COG : ', ' ENERGY: ', e15.8, ' (MeV), TOF: ', e15.8, ' (SEC)', /)
15792  write (16, 167) qmd, surm, qdp, qdpde, qdisp, cor12, pent12, pent21
15793 167 format (3x, ' ***', ' 2nd ORDER MOMENTS :', e12.5, ' (RD DP/P)**2', ' SURFACE : ', e12.5, ' (DEG DP/P)', /, 6x, &
15794  ' 1/2 EXTENSION PHASE : ', e12.5, ' RD ', ' OR ', e12.5, ' DEG', /, 6x, ' 1/2 EXTENSION DISPERSION : ', e15.8, &
15795  ' IN DP/P ', /, 6x, ' CORRELATION COEF : ', e15.8, /, 6x, ' DISPERSION SLOPE: ', e15.8, ' (DP/P)/RD ', /, 6x, &
15796  ' PHASE SLOPE : ', e15.8, ' (DP/P)/RD ')
15797  ! GRAPHE DE L ELLIPSE
15798  step = qdpde/50.
15799  tta = exten(3)*180.*180./(pi*pi)
15800  do i = 1, 101
15801  xii = -qdpde + step*float(i-1)
15802  xx(i) = xii
15803  xx(202-i) = xx(i)
15804  ttb = exten(11)*xii*180./pi
15805  ttc = exten(10)*xii**2 - qmdw*rmsmtp*180.*180./(pi*pi)
15806  ttcb = ttb**2 - ttc*tta
15807  if (ttcb<=0.) ttcb = 0.
15808  if (tta==0.) then
15809  yi = 0.
15810  yii = 0.
15811  else
15812  quot = ttcb/tta**2
15813  yi = ttb/tta - sqrt(quot)
15814  yii = ttb/tta + sqrt(quot)
15815  end if
15816  yy(i) = yi
15817  yy(202-i) = yii
15818  end do
15819  enihrf = 0.
15820  if (idwdp==0) then
15821  ! Alvarez
15822  do i = 1, 201
15823  write (66, *) xx(i), yy(i)
15824  end do
15825  else
15826  ! IH
15827  bref = vref/vl
15828  gref = 1./sqrt(1.-bref*bref)
15829  enihrf = xmat*(gref-1.)
15830  phihrf = fh*(tcog-tref)*180./pi
15831  do i = 1, 201
15832  axx = phihrf
15833  ayy = encog - enihrf - xmat
15834  write (66, *) xx(i) + axx, yy(i) + ayy
15835  end do
15836  end if
15837  ! write particle coordinates to graphics file
15838  do i = 1, ngood
15839  if (idwdp==0) then
15840  ! Alvarez like
15841  xx(i) = fh*(f(6,i)-tcog)*180./pi
15842  yy(i) = f(7, i) - encog
15843  if (imcs==1) cs(i) = f(9, i)
15844  end if
15845  if (idwdp==1) then
15846  ! IH like
15847  xx(i) = fh*(f(6,i)-tref)*180./pi
15848  yy(i) = f(7, i) - enihrf - xmat
15849  if (imcs==1) cs(i) = f(9, i)
15850  end if
15851  end do
15852  ! write particle coordinates to graphics file
15853  write (66, *) ngood
15854  if (imcs==0) then
15855  if (nzone==0) then
15856  do i = 1, ngood
15857  write (66, *) xx(i), yy(i)
15858  end do
15859  else
15860  do i = 1, ngood
15861  write (66, *) xx(i), yy(i), f(10, i)
15862  end do
15863  end if
15864  else
15865  do i = 1, ngood
15866  write (66, *) xx(i), yy(i), cs(i)
15867  end do
15868  end if
15869  ! plot emittance with chase (if applicable)
15870  ! if (chasit) call ytzprc(glim,oldcog,idwdp)
15871  if (igrprm==2 .or. igrprm==3) then
15872  ! restore limits in GLIM(j,k)
15873  do j = 1, 4
15874  do k = 1, 2
15875  glim(j, k) = slim(j, k)
15876  end do
15877  end do
15878  end if
15879  tref = satref
15880  vref = savref
15881  return
15882  end subroutine ytzp
15883  ! *******************************************************************
15884  ! SUBROUTINE grcomp(text,iskale)
15885  ! routine for plots
15886  ! *******************************************************************
15887  subroutine grcomp(text, iskale)
15888  implicit real *8(a-h, o-z)
15889  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
15890  character *80 text, patitl
15891  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
15892  common /faisc/f(10, iptsz), imax, ngood
15893  common /stis/suryth, surzph, enedep, ecogde, testca
15894  common /fene/wdisp, wphas, wx, wy, rlim, ifw
15895  common /consta/vl, pi, xmat, rpel, qst
15896  common /dyn/tref, vref
15897  common /tapes/in, ifile, meta
15898  common /etcom/cog(8), exten(17), fd(iptsz)
15899  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
15900  common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
15901  common /mcs/imcs, ncstat, cstat(20)
15902  common /zones/frms(6), nzone
15903  common /hist/xpos(200), xn(200), ypos(200), yn(200), zpos(200), zn(200), ixt, iyt, izt
15904  common /hist1/xps(200), xpn(200), yps(200), ypn(200), zps(200), zpn(200), ixpt, iypt, izpt
15905  logical chasit
15906  dimension xx(iptsz), yy(iptsz), cs(iptsz)
15907  dimension slim(4, 2)
15908 
15909  tcog = 0.
15910  do i = 1, ngood
15911  tcog = f(6, i) + tcog
15912  end do
15913  tcog = tcog/float(ngood)
15914  if (igrprm==1) then
15915  text = patitl
15916  end if
15917  if (igrprm==2) then
15918  text = patitl
15919  ! save limits in GLIM(j,k)
15920  do j = 1, 4
15921  do k = 1, 2
15922  slim(j, k) = glim(j, k)
15923  glim(j, k) = glim1(j, k)
15924  end do
15925  end do
15926  end if
15927  if (igrprm==3) then
15928  text = patitl
15929  ! save limits in GLIM(j,k)
15930  do j = 1, 4
15931  do k = 1, 2
15932  slim(j, k) = glim(j, k)
15933  glim(j, k) = glim2(j, k)
15934  end do
15935  end do
15936  end if
15937  write (16, *)
15938  write (16, *) 'LIMITS', ((glim(j,k),k=1,2), j=1, 4)
15939  ! X-Z start
15940  xyliz = glim(4, 1)*vref*pi/(180.*fh)
15941  zlix = xyliz
15942  xlix = glim(3, 1)
15943  dstrly = glim(4, 2)
15944 
15945  ! Store header and particle coordinates in binary file for
15946  ! graphics post-processor
15947 
15948  ! igrtyp is type of graph
15949  ! igrtyp=2 for grcomp extra plots
15950  ! igrtyp=7 for grcomp extra plots with multi charge state beam
15951  ! igrtyp=12 for grcomp extra plots with ZONES card
15952  igrtyp = 2
15953  if (nzone/=0) igrtyp = 12
15954  if (imcs==1) igrtyp = 7
15955  ! igrtyp=2,7,12 --> normal scale in envelopes
15956  ! igrtyp=17,22,27 --> log scale in envelopes
15957  if (iskale==1) then
15958  write (66, *) igrtyp + 15
15959  write (66, *) dstrly
15960  else
15961  write (66, *) igrtyp
15962  end if
15963  if (igrtyp==7) then
15964  write (66, *) ncstat
15965  write (66, *)(cstat(j), j=1, ncstat)
15966  end if
15967  if (igrtyp==12) then
15968  write (66, *) nzone
15969  write (66, *)(frms(j), j=2, nzone), ' 0.'
15970  end if
15971  write (66, *) text
15972  ! new
15973  xx(1) = zlix
15974  yy(1) = xlix
15975  write (66, *) - xx(1), xx(1), -yy(1), yy(1)
15976  ! 120 CONTINUE
15977  if (imcs==1) then
15978  do i = 1, ngood
15979  cs(i) = f(9, i)
15980  end do
15981  end if
15982  if (idwdp==0) then
15983  ! Alvarez type (plot w.r.t. reference)
15984  do i = 1, ngood
15985  gpai = f(7, i)/xmat
15986  bpai = sqrt(1.-1./(gpai*gpai))
15987  xx(i) = (tcog-f(6,i))*vl*bpai
15988  yy(i) = f(2, i)
15989  end do
15990  else
15991  ! IH type (plot w.r.t. centre of gravity)
15992  do i = 1, ngood
15993  gpai = f(7, i)/xmat
15994  bpai = sqrt(1.-1./(gpai*gpai))
15995  xx(i) = (tref-f(6,i))*vl*bpai
15996  yy(i) = f(2, i)
15997  end do
15998  end if
15999  ! write particle coordinates to graphics file
16000  write (66, *) ngood
16001  if (imcs==0) then
16002  if (nzone==0) then
16003  do i = 1, ngood
16004  write (66, *) xx(i), yy(i)
16005  end do
16006  else
16007  do i = 1, ngood
16008  write (66, *) xx(i), yy(i), f(10, i)
16009  end do
16010  end if
16011  else
16012  do i = 1, ngood
16013  write (66, *) xx(i), yy(i), cs(i)
16014  end do
16015  end if
16016  ! Y-Z start
16017  zliy = xyliz
16018  zliy = glim(3, 2)
16019  xx(1) = zlix
16020  yy(1) = zliy
16021  write (66, *) - xx(1), xx(1), -yy(1), yy(1)
16022  ! 1200 CONTINUE
16023  if (idwdp==0) then
16024  ! Alvarez type (plot w.r.t. reference)
16025  do i = 1, ngood
16026  gpai = f(7, i)/xmat
16027  bpai = sqrt(1.-1./(gpai*gpai))
16028  xx(i) = (tcog-f(6,i))*vl*bpai
16029  yy(i) = f(4, i)
16030  end do
16031  else
16032  ! IH type (plot w.r.t. centre of gravity)
16033  do i = 1, ngood
16034  gpai = f(7, i)/xmat
16035  bpai = sqrt(1.-1./(gpai*gpai))
16036  xx(i) = (tref-f(6,i))*vl*bpai
16037  yy(i) = f(4, i)
16038  end do
16039  end if
16040  ! write particle coordinates to graphics file
16041  write (66, *) ngood
16042  if (imcs==0) then
16043  if (nzone==0) then
16044  do i = 1, ngood
16045  write (66, *) xx(i), yy(i)
16046  end do
16047  else
16048  do i = 1, ngood
16049  write (66, *) xx(i), yy(i), f(10, i)
16050  end do
16051  end if
16052  else
16053  do i = 1, ngood
16054  write (66, *) xx(i), yy(i), cs(i)
16055  end do
16056  end if
16057  ! 1400 CONTINUE
16058  ! beam profile plots for X,Y & Z
16059  call histgrm
16060  write (66, *) ixt
16061  do i = 1, ixt
16062  write (66, *) xpos(i), xn(i)
16063  end do
16064  write (66, *) iyt
16065  do i = 1, iyt
16066  write (66, *) ypos(i), yn(i)
16067  end do
16068  write (66, *) izt
16069  do i = 1, izt
16070  write (66, *) zpos(i), zn(i)
16071  end do
16072  ! beam profile plots for Xp,Yp & Zp
16073  write (66, *) ixpt
16074  do i = 1, ixpt
16075  write (66, *) xps(i), xpn(i)
16076  end do
16077  write (66, *) iypt
16078  do i = 1, iypt
16079  write (66, *) yps(i), ypn(i)
16080  end do
16081  write (66, *) izpt
16082  do i = 1, izpt
16083  write (66, *) zps(i), zpn(i)
16084  end do
16085  if (igrprm==2 .or. igrprm==3) then
16086  ! restore limits in GLIM(j,k)
16087  do j = 1, 4
16088  do k = 1, 2
16089  glim(j, k) = slim(j, k)
16090  end do
16091  end do
16092  end if
16093  return
16094  end subroutine grcomp
16095  ! *******************************************************************
16096  ! SUBROUTINE restay
16097  ! motion of particles in a cavity
16098  ! the field can be read from disk in the form (z,E(z)) or it can be
16099  ! listed in the form of a Fourier series expansion
16100  ! *******************************************************************
16101  subroutine restay
16102  implicit real *8(a-h, o-z)
16103  ! ****************************************************
16104  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
16105  common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
16106  fhpar, nc
16107  common /posi/ist
16108  common /midgap/enmil, vapmi
16109  common /azmtch/dlg, xmcph, xmce
16110  common /azlist/icont, iprin
16111  common /itvole/itvol, imamin
16112  common /func/a(200), ylg, atte, ncel, nharm
16113  ! TRANSIT TIME COEFFICIENTS
16114  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
16115  common /ttfcb/t3k, t4k, s3k, s4k
16116  common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
16117  common /jacob/gaks, gaps
16118  common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
16119  xk1ii, xk2ii
16120  common /faisc/f(10, iptsz), imax, ngood
16121  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16122  common /rfield/ifield
16123  common /qmoyen/qmoy
16124  common /rigid/boro
16125  common /cdek/dwp(iptsz)
16126  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
16127  common /consta/vl, pi, xmat, rpel, qst
16128  common /dyn/tref, vref
16129  common /compt/nrres, nrtre, nrbunc, nrdbun
16130  common /compt1/ndtl, ncavmc, ncavnm
16131  common /fene/wdisp, wphas, wx, wy, rlim, ifw
16132  common /tapes/in, ifile, meta
16133  common /ranec1/dummy(6)
16134  common /etcom/cog(8), exten(17), fd(iptsz)
16135  common /speda/dave, idave
16136  common /shif/dtiph, shift
16137  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
16138  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
16139  common /dcspa/iesp
16140  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
16141  common /appel/irstay, ilost, iavp, ispcel
16142  common /posc/xpsc
16143  common /pstpla/tstp
16144  common /femt/iemgrw, iemqesg
16145  common /mode/eflvl, rflvl
16146  common /aerp/vphase, vfield, ierpf
16147  common /tofev/ttvols
16148  ! **** reference
16149  ! **** DWRFS(MeV): energy gain
16150  ! **** SPHRFS(rad):phase jump
16151  ! **** PHRFS(rad):phase
16152  ! **** common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
16153  logical iesp, ichaes, irstay, iavp, ispcel, ifield, iemgrw
16154  logical shift, chasit, itvol, imamin, dave
16155  character *1 cr
16156  ! ************************************************************
16157  ! XESLN : NEGATIVE LENGHT OF THE DRIFT FOLLOWING THE GAP
16158  ! IF XESLN N.E.0 THEN THE CHARGE SPACE EFFECT IMPLIES THE
16159  ! LENGTH (YLG-XESLN)
16160  nrres = nrres + 1
16161  ncavmc = ncavmc + 1
16162  ! allow for print out on terminal of gap# on one and the same line
16163  cr = char(13)
16164  write (6, 8254) nrtre, nrres, cr
16165 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
16166  write (16, *) ' CAVITY N :', nrres
16167  ilost = 0
16168  aqst = abs(qst)
16169  qmoy = aqst
16170  ! --- the frequency fh may be changed with delfh
16171  oldfh = fh
16172  ! IDUM : dummy variable (indicate in input file the number of the cavity)
16173  read (in, *) idum
16174 
16175  ! --- XESLN (cm): difference between the length of the field YLG and the physical length of the cavity
16176  ! (The space charge is acting on the length (YLG-XESLN) )
16177  ! dphase (deg): phase offset from the phase crest (giving the maximum of energy gain)
16178  ! FFIELD : in percent;
16179  ! (electric field)=(initial electric field)*(1.+FFIELD/100)
16180  ! isec: flag
16181  ! isec = 0 : The crest phase (or the valley) is adjusted at the entrance of the accelerating element
16182  ! isec = 1 : The crest phase (or the valley)is adjusted at the middle of the accelerating element
16183 
16184  ! idum is for compatability with CAVNUM
16185  read (in, *) xesln, dphase, ffield, isec, idum
16186  ffield = 1. + ffield/100.
16187  if (ifield) then
16188  ! --- The field is read on the disk in file 'field.txt' in the form:
16189  ! z (cm) E(z) MV/cm
16190  ! fhc: frequency of the cavity (Hertz) (read in the file 'field.txt' )
16191  fh = fhc*2.*pi
16192  ncel = ncell
16193  atte = att
16194  ye0 = atte
16195  ! flength : length of the field (cm)
16196  ylg = flength
16197  scdist = ylg - abs(xesln)
16198  else
16199  ! --- The field is read in the input list in the form of a Fourier series
16200  oldfh = fh
16201  ! atte: factor acting on the amplitude of the field (read in the input list)
16202  ye0 = atte
16203  scdist = ylg - abs(xesln)
16204  end if
16205  dphete = dphase
16206  if (itvol .and. imamin) then
16207  ! --- adjustment of the phase offset w.r.t. the t.o.f. (deg)
16208  ottvol = fh*ttvols*180./pi
16209  attvol = ottvol
16210  xkpi = ottvol/360.
16211  ixkpi = int(xkpi)
16212  xkpi = (xkpi-float(ixkpi))*360.
16213  dphase = dphase - xkpi
16214  end if
16215  ! --- iesp, irstay and ispcel: logical flags for space charge computations
16216  iesp = .false.
16217  irstay = .true.
16218  ispcel = .true.
16219  ! --- dwp(*): array reserved to space charge computations
16220  do i = 1, iptsz
16221  dwp(i) = 0.
16222  end do
16223  write (16, 150) fh/(2.*pi), ylg, atte, ffield, ncel
16224 150 format (4x, 'FREQUENCY :', e12.5, ' Hertz', /, 4x, 'FIELD LENGTH :', e12.5, ' cm', /, 4x, &
16225  'FIELD FACTOR (UNITS CONVERSION) :', e12.5, /, 4x, 'FIELD FACTOR (ATTENUATION) :', f12.6, /, 4x, &
16226  'FIELD DIVIDED IN: ', i4, ' SECTIONS ')
16227  if (.not. imamin) write (16, *) ' PHASE OFFSET: ', dphete, ' DEG'
16228  if (imamin) write (16, 1501) dphete, dphase, xkpi
16229 1501 format (4x, 'PHASE OFFSET (before adjustment): ', e12.5, ' deg', /, 4x, 'PHASE OFFSET (after adjustment): ', &
16230  e12.5, ' deg', /, 4x, 'ADJUSTMENT ON THE PHASE OFFSET: ', e12.5, ' deg')
16231  beref = vref/vl
16232  fh0 = fh/vl
16233  ! --- prediction of transit time factors TK and SK based on the velocity at the entrance
16234  tk = tta0(beref)/2.*ffield
16235  sk = tsb0(beref)/2.*ffield
16236  ! --- prediction of PCREST (phase of RF giving the maximum of energy gain in the cavity)
16237  pcrest = atan(-sk/tk)
16238  ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16239  if (ddwc<0.) pcrest = pcrest + pi
16240  ! --- ttvol: time of flight at entrance (sec)
16241  ttvol = 0.
16242  if (itvol) ttvol = ttvols*fh
16243  ! start file 'short.data'
16244  ! --- dav1(idav,3)=0: the particle reference and the cog coincide at the input
16245  ! --- dav1(idav,3)=1: the particle reference and the cog are independent
16246  dav1(idav, 3) = 0.
16247  idav = idav + 1
16248  iitem(idav) = 1
16249  dav1(idav, 1) = ylg*10.
16250  dav1(idav, 2) = ye0*100.
16251  tstp = (davtot+ylg*xpsc)*10.
16252  davtot = davtot + ylg
16253  dav1(idav, 24) = davtot*10.
16254  dav1(idav, 40) = fh
16255  if (iprf==1) call stapl(dav1(idav,24))
16256  iarg = 1
16257  call cdg(iarg)
16258  enold = cog(1)
16259  encog = enold
16260  gcog = enold/xmat
16261  bcog = sqrt(1.-1./(gcog*gcog))
16262  tcog = cog(3)
16263  if (shift) then
16264  ! --- the reference particle and the cog are independent
16265  beref = vref/vl
16266  gamref = 1./sqrt(1.-(beref*beref))
16267  enref = xmat*gamref
16268  trefdg = tref*fh*180./pi
16269  dav1(idav, 3) = 1.
16270  else
16271  ! --- the reference particle and the cog are coinciding
16272  beref = bcog
16273  vref = bcog*vl
16274  tref = tcog
16275  gamref = gcog
16276  enref = cog(1)
16277  dav1(idav, 3) = 0.
16278  end if
16279  ! --- the reference particle is put in the array f(10,iptsz) at the position ngdrf = ngood + 1
16280  ! **** ngdrf=ngood+1
16281  ! **** BEREF=VREF/VL
16282  ! **** GAMREF=1./SQRT(1.-(BEREF*BEREF))
16283  ! **** ENREF=XMAT*GAMREF
16284  ! **** f(1,ngdrf)=ngdrf
16285  ! **** f(2,ngdrf)=0.
16286  ! **** f(3,ngdrf)=0.
16287  ! **** f(4,ngdrf)=0.
16288  ! **** f(5,ngdrf)=0.
16289  ! **** f(6,ngdrf)=tref
16290  ! **** f(7,ngdrf)=enref
16291  ! **** f(8,ngdrf)=1.
16292  ! **** f(9,ngdrf)=qst
16293  ! **** f(10,ngdrf)=0.
16294  if (dav1(idav,3)==1.) write (16, *) ' ****reference and cog evolve independently'
16295  if (dav1(idav,3)==0.) write (16, *) ' **** the reference is the cog '
16296  write (16, 178)
16297 178 format (/, ' Dynamics at the input', /, 5x, ' BETA GAMMA ENERGY(MeV) ', ' TOF(deg) TOF(sec)')
16298  write (16, 1788) bcog, gcog, encog - xmat, tcog*fh*180./pi, tcog
16299 1788 format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
16300  enrprin = enref - xmat
16301  write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
16302 165 format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
16303  tofprt = tref
16304  iprint = 0
16305  call statis
16306  xk1 = fh/vref
16307  ! --- prediction of transit time factors based on an average value of velocity
16308  ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16309  enrefs = enref + ddw
16310  gams = enrefs/xmat
16311  bets = sqrt(1.-1./(gams*gams))
16312  bemy = (gams+gamref)/(gams*bets+gamref*beref)
16313  bemy = 1./bemy
16314  tk0 = tta0(bemy)/2.*ffield
16315  tpk0 = tta1(bemy)/2.*ffield
16316  tppk0 = tta2(bemy)/2.*ffield
16317  tp3k0 = tta3(bemy)/2.*ffield
16318  tp4k0 = tta4(bemy)/2.*ffield
16319  sk0 = tsb0(bemy)/2.*ffield
16320  spk0 = tsb1(bemy)/2.*ffield
16321  sppk0 = tsb2(bemy)/2.*ffield
16322  sp3k0 = tsb3(bemy)/2.*ffield
16323  sp4k0 = tsb4(bemy)/2.*ffield
16324  tk = tk0
16325  t1k = tpk0
16326  t2k = tppk0
16327  t3k = tp3k0
16328  t4k = tp4k0
16329  sk = sk0
16330  s1k = spk0
16331  s2k = sppk0
16332  s3k = sp3k0
16333  s4k = sp4k0
16334  ! ---- prediction of PCREST (crest phase) based on the actual coefficients factors T and S
16335  pcrest = atan(-sk0/tk0)
16336  ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16337  if (ddwc<0.) pcrest = pcrest + pi
16338  ! --- the routine crest is computing the equivalent field lenght: EQVL
16339  call crest(bemy, eqvl, xpos, sqcttf, ffield)
16340  ! --- follow computations of the parameters:
16341  ! equivalent field length (cm)
16342  ! asociated drift length (cm)
16343  ! slip of phase (rad)
16344  ! energy gain (MeV)
16345  ! phase jump (rad)
16346  ! average k (=frequency/velocity) (cm-1)
16347  ! transit time coefficients (MeV,cm)
16348  ! crest phase (rd)
16349  ! phase of RF at entrance (rd)
16350  saphi = pcrest
16351  ! --- start iterations: improve the average velocity and the transit time factors
16352  do it = 1, 3
16353  dts = (tk*t1k+sk*s1k)/(tk*tk+sk*sk)
16354  fk1 = 2.*dts
16355  eqvlp = eqvl
16356  ! --- computation of the phase slip: PHSLIP
16357  phslip = -4.*atan(3.2*dts/eqvl)
16358  if (phslip/=0.) then
16359  til2 = phslip/2.
16360  do iiii = 1, 4
16361  gx = 1./tan(til2) - 1./til2 - fk1/eqvlp
16362  gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
16363  til2 = til2 - gx/gpx
16364  hx = 1./tan(til2) - 1./til2
16365  eqvlp = fk1/hx
16366  end do
16367  phslip = til2*2.
16368  end if
16369  peqvl = xpos
16370  asdl = peqvl - eqvl/2.
16371  f0 = xitl0(gamref, gams, bemy, saphi, aqst)
16372  delwrm = (f0-gamref)*xmat
16373  enrs = enref + delwrm
16374  gams = enrs/xmat
16375  bets = sqrt(1.-1./(gams*gams))
16376  ! --- computation of the jump of phase:DELPHR
16377  coeph = fh*aqst/(vl*xmat)
16378  f3 = xitl3(gamref, gams, bemy, it, saphi, aqst)
16379  delphr = coeph*f3
16380  xk2 = fh0/bets
16381  xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
16382  bemy = fh0/xkm
16383  ! --- computations of transit time factors
16384  tk = tta0(bemy)/2.*ffield
16385  t1k = tta1(bemy)/2.*ffield
16386  sk = tsb0(bemy)/2.*ffield
16387  s1k = tsb1(bemy)/2.*ffield
16388  end do
16389  ! --- crest phase PCREST (after iterations)
16390  pcrest = atan(-sk/tk)
16391  ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16392  if (ddwc<0.) pcrest = pcrest + pi
16393  dcemd = 0.
16394  ! --- isec = 0: the phase offset is given relative to the entrance of the cavity
16395  ! --- isec = 1: the phase offset is given relative to the middle of the cavity
16396  ! --- (vapmi has been computed in the function XITL3 (in deg) )
16397  if (isec/=0) then
16398  imedi = int(vapmi/360.+.4)
16399  dcemd = vapmi - 360.*imedi
16400  write (16, 773) nrres, enmil, vapmi, dcemd
16401 773 format (2x, ' AT THE MIDDLE OF THE CAVITY:', i4, /, 2x, ' *ENERGY :', e12.5, ' MEV *PHASE :', e12.5, ' DEG', &
16402  2x, ' *SLIP OF PHASE :', e12.5, ' deg', /)
16403  dcemd = dcemd*pi/180.
16404  end if
16405  ! SAPHI: phase of RF w.r.t. the phase offset
16406  dphase = dphase*pi/180.
16407  saphi = pcrest + dphase + ttvol - dcemd
16408  ddw = aqst*(tk0*cos(saphi)-sk0*sin(saphi))
16409  enrs = enref + ddw
16410  gams = enrs/xmat
16411  ! --- start new iterations to improve:
16412  ! transit time factors
16413  ! phase slip
16414  ! jump of phase
16415  ! crest phase
16416  ! phase of RF
16417 
16418  sapho = saphi
16419  do it = 1, 3
16420  dts = (tk*t1k+sk*s1k)/(tk*tk+sk*sk)
16421  fk1 = 2.*dts
16422  eqvlp = eqvl
16423  phslip = -4.*atan(3.2*dts/eqvl)
16424  if (phslip/=0.) then
16425  til2 = phslip/2.
16426  do iiii = 1, 3
16427  gx = 1./tan(til2) - 1./til2 - fk1/eqvlp
16428  gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
16429  til2 = til2 - gx/gpx
16430  hx = 1./tan(til2) - 1./til2
16431  eqvlp = fk1/hx
16432  end do
16433  phslip = til2*2.
16434  end if
16435  peqvl = xpos
16436  asdl = peqvl - eqvl/2.
16437  ! --- ENERGY GAIN AND PHASE JUMP
16438  f0 = xitl0(gamref, gams, bemy, saphi, aqst)
16439  delwrm = (f0-gamref)*xmat
16440  enrs = enref + delwrm
16441  gams = enrs/xmat
16442  bets = sqrt(1.-1./(gams*gams))
16443  xk2 = fh0/bets
16444  ! --- DELPHR: jump of phase
16445  coeph = fh*aqst/(vl*xmat)
16446  f2 = xitl3(gamref, gams, bemy, it, saphi, aqst)
16447  delphr = coeph*f2
16448  ! --- XKM: average k = frequency/velocity)
16449  xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
16450  bemy = fh0/xkm
16451  ! --- TRANSIT TIME FACTORS (based on the velocity BEMY)
16452  tk = tta0(bemy)/2.*ffield
16453  t1k = tta1(bemy)/2.*ffield
16454  t2k = tta2(bemy)/2.*ffield
16455  t3k = tta3(bemy)/2.*ffield
16456  t4k = tta4(bemy)/2.*ffield
16457  sk = tsb0(bemy)/2.*ffield
16458  s1k = tsb1(bemy)/2.*ffield
16459  s2k = tsb2(bemy)/2.*ffield
16460  s3k = tsb3(bemy)/2.*ffield
16461  s4k = tsb4(bemy)/2.*ffield
16462  pcrest = atan(-sk/tk)
16463  ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
16464  if (ddwc<0.) pcrest = pcrest + pi
16465  dphii = (xk1-xk2)*eqvl/10. + (xkp1+xkp2)/120.*eqvl*eqvl + (xk1-xkm)*asdl
16466  ! --- phase of RF
16467  ! *2011*July*16 DPHII sign
16468  ! *2011 SV SAPHI=PCREST+DPHASE+TTVOL-DCEMD+DPHII
16469  ! *2011 ET SAPHI=PCREST+DPHASE+TTVOL-DCEMD-DPHII
16470  saphi = pcrest + dphase + ttvol - dcemd + dphii
16471  end do
16472  savph = saphi*180./pi
16473  ! REFERENCE PARTICLE BASED ON CHARGE STATE: QMOY = ABS(QST)
16474  cfh = fh/(vl*2.*xmat)
16475  ckh = qmoy*qmoy/(4.*xmat*xmat)
16476  dphii = (xk1-xk2)*eqvl/10. + (xkp1+xkp2)/120.*eqvl*eqvl + (xk1-xkm)*asdl
16477  phares = saphi + xk2*ylg + delphr
16478  ! ***** TEST
16479  ! DITEMP=(2.*XK1*ASDL+XKM*(EQVL-ASDL)+
16480  ! x XK2*(YLG-(EQVL+ASDL)))/FH+DELPHR/FH
16481  ! cc DITEMP=(XK1*ASDL+XKM*(EQVL)+
16482  ! cc x XK2*(YLG-(EQVL+ASDL)))/FH+DELPHR/FH
16483  trefs = tref + (xk2*ylg+delphr)/fh
16484  ! cc TREFS1=TREF+DITEMP
16485  ! cc write(6,*) 'trefs trefs1 ',trefs,trefs1
16486  ! cc pause
16487  ! ****************************
16488  phared = (phares-saphi)*180./pi
16489  tredg = fh*trefs*180./pi
16490  ! ****** REFERENCE BASED ON THE AVERAGE CHARGE STATE QMOY (if several charges state)
16491  ! ******* CFH=FH/(VL*2.*XMAT)
16492  ! ****** CKH=QMOY*QMOY/(4.*XMAT*XMAT)
16493  ! ****** save the energy and the T.O.F of the particle reference at the input of the cavity
16494  ! ****** enri=f(7,ngdrf)
16495  ! ***** trefi=f(6,ngdrf)
16496  ! ***** call gap(gamref,saphi,gams,delphr)
16497  ! ***** trefs and enrs: time of flight and energy of the reference and the output of the cavity
16498  ! ***** trefs=f(6,ngdrf)
16499  ! ***** enrs=f(7,ngdrf)
16500  ! ***** grefs=f(7,ngdrf)/xmat
16501  ! ***** bets=sqrt(grefs*grefs-1.)/grefs
16502  ! ***** dwrfs=enrs-enri
16503  ! ***** PHARES=SAPHI+XK2*YLG+DELPHR
16504  ! ***** TREFS=TREF+(XK2*YLG+DELPHR)/FH
16505  ! ***** TREDG=fh*TREFS *180./PI
16506  write (16, *) ' PARAMETERS RELATING TO THE REFERENCE PARTICLE '
16507  write (16, *) '***********************************************'
16508  write (16, *) ' ENERGY GAIN(MeV) ', delwrm, ' TOF ', tredg, ' DEG'
16509  write (16, *) ' PHASE JUMP(DG) ', delphr*180./pi
16510  write (16, *) ' SLIP OF PHASE AT THE INPUT(DG) ', sapho*180./pi
16511  write (16, *) ' PHASE OF RF AT ENTRANCE(DG) ', savph
16512  write (16, *) ' AVERAGE k (cm-1) (freq./velocity): ', xkm
16513  write (16, *) ' Associated drift length ', asdl, ' (cm)'
16514  write (16, *) ' Equivalent field length ', eqvl, ' cm center at ', xpos, ' cm'
16515  write (16, *) ' TRANSIT TIME FACTORS AND DERIVATIVES (MeV,cm):'
16516  write (16, *) ' T ', tk, t1k, t2k, t3k, t4k
16517  write (16, *) ' S ', sk, s1k, s2k, s3k, s4k
16518  write (16, *) ' PHASE SLIP(DEG) ', phslip*180./pi
16519  write (16, *) ' CREST PHASE OF RF (DEG) ', pcrest*180./pi
16520  write (16, *) ' MAGNITUDE ', sqcttf, ' MV/cm'
16521  t0s = sqrt(tk*tk+sk*sk)
16522  write (16, *) ' T0 ', t0s
16523  ! *************************************************************************
16524  call gap(gamref, saphi, gams, delphr)
16525  iarg = 1
16526  call cdg(iarg)
16527  encog = cog(1)
16528  gcog = encog/xmat
16529  bcog = sqrt(1.-1./(gcog*gcog))
16530  tcog = cog(3)
16531  call ext2d(1)
16532  ! print in file 'short.data'
16533  ! 3.12.09 phnew=-(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
16534  ! 3.12.09 dav1(idav,6)=encog-xmat
16535  ! 3.12.09 dav1(idav,7)=phnew
16536  if (itvol) then
16537  dav1(idav, 38) = dphete
16538  dav1(idav, 39) = dphase*180./pi
16539  else
16540  dav1(idav, 38) = dphete
16541  end if
16542  write (16, 3777)
16543 3777 format (/, ' Dynamics at the output', /, 5x, ' BETA dW(MeV) ENERGY(MeV) ', ' TOF(deg) TOF(sec)')
16544  engain = encog - enold
16545  write (16, 3473) bets, delwrm, enrs - xmat, fh*trefs*180./pi, trefs
16546 3473 format (' REF ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
16547  write (16, 1789) bcog, engain, encog - xmat, tcog*fh*180./pi, tcog
16548 1789 format (' COG ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
16549  testca = exten(1)*exten(2)*exten(3)
16550  ! epsil=1.E-20
16551  epsil = 1.e-40
16552  if (abs(testca)>epsil) then
16553  qdisp = 2.*sqrt(exten(1))
16554  qmd = exten(1)*exten(3) - exten(2)**2
16555  sqmdv = 4.*pi*sqrt(qmd)
16556  surm = 4.*pi*sqrt(qmd)*180./pi
16557  qdp = 2.*sqrt(exten(3))
16558  cor12 = exten(2)/sqrt(exten(1)*exten(3))
16559  ! omment PENT12=SQRT(exten(1)/exten(3))/COR12
16560  ! omment PENT21=SQRT(exten(1)/exten(3))*COR12
16561  qdpde = qdp*180./pi
16562  else
16563  qdisp = 0.
16564  qmd = 0.
16565  sqmdv = 0.
16566  surm = 0.
16567  qdp = 0.
16568  cor12 = 0.
16569  pent12 = 0.
16570  pent21 = 0.
16571  qdpde = 0.
16572  end if
16573  trqtx = exten(4)*exten(5) - exten(8)**2
16574  trqpy = exten(6)*exten(7) - exten(9)**2
16575  qditax = 2.*sqrt(exten(4))
16576  qdiant = 2.*sqrt(exten(5))
16577  qditay = 2.*sqrt(exten(6))
16578  qdianp = 2.*sqrt(exten(7))
16579  surxth = 4.*pi*sqrt(trqtx)
16580  suryph = 4.*pi*sqrt(trqpy)
16581  if (shift) then
16582  vref = bets*vl
16583  tref = trefs
16584  else
16585  vref = bcog*vl
16586  tref = tcog
16587  end if
16588  if (itvol) then
16589  ttvols = tref
16590  ! omment dphete=dgphr
16591  ! omment attvol=fh*ttvols*180./pi
16592  ! omment write(16,7456) ottvol,attvol
16593  end if
16594  ! omment 7456 format(2x,'***tof at the input: ',e12.5,' deg',/,
16595  ! omment * 2x,'***tof at the output: ',e12.5,' deg')
16596  call statis
16597  ! ENVEL
16598  call stapl(dav1(idav,24))
16599  ! omment WRITE(16,9998) SQMDV
16600  ! omment9998 FORMAT(2X,' EMITTANCE (norm): ',
16601  ! omment * E12.5,' PI*MEV*RAD')
16602  dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
16603  ! 3.12.09 dav1(idav,17)=surxth*10./pi
16604 
16605  dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
16606  dav1(idav, 25) = nrres
16607  dav1(idav, 30) = ngood
16608 
16609  ! print in the file: 'dynac.dmp':
16610  ! gap number, phase offset(deg), relativistic beta, energy(MeV), horz. emit.(mm*mrd,norm), vert.
16611  ! emit.(mm*mrd,norm),long. emit(keV*sec)
16612 
16613  ! --- dav1(idav,16): Emittance(norm) x-xp (mm*mrad)
16614  ! --- dav1(idav,21): Emittance(norm) y-yp (mm*mrad)
16615  emns = 1.e12*sqmdv/(pi*fh)
16616  ! et2010s
16617  tcgprt = fh*tcog*180./pi
16618  trfprt = fh*tref*180./pi
16619  ! cavity number, z (m), transmission (%), synchronous phase (deg), time of flight (deg) (reference),
16620  ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
16621  ! (MeV),
16622  ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
16623  ! longitudinal emittance (RMS, ns.keV)
16624  trnsms = 100.*float(ngood)/float(imax)
16625  if (ncavmc==1) write (50, *) '# cavmc.dmp'
16626  if (ncavmc==1) write (50, *) '# cav Z trans ', &
16627  'PHIs TOF(COG) COG Wcog TOF(REF) ', &
16628  ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS'
16629  if (ncavmc==1) write (50, *) '# # (m) (%) ', &
16630  '(deg) (deg) beta (MeV) (deg) ', &
16631  ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)'
16632  write (50, 7023) nrres, 0.001*dav1(idav, 24), trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, &
16633  enrs - xmat, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
16634 7023 format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
16635  ! et2010e
16636  fh = oldfh
16637  ! new magnetic rigidity of the reference
16638  gref = 1./sqrt(1.-bets*bets)
16639  xmor = xmat*bets*gref
16640  boro = 33.356*xmor*1.e-01/aqst
16641  write (16, *) ilost, ' particles lost in cavity ', nrres
16642  call emiprt(0)
16643  return
16644  end subroutine restay
16645  ! *******************************************************************
16646  ! SUBROUTINE fieldcav(atte)
16647  ! read from disk the electromagnetic field in the form (z,E(z))
16648  ! SUPERFISH units: z(m) E(z) (Volt/m)
16649  ! converted to: z(cm) E(z) (MVolt/cm)
16650  ! *******************************************************************
16651  subroutine fieldcav(atte)
16652  implicit real *8(a-h, o-z)
16653  common /consta/vl, pi, xmat, rpel, qst
16654  common /rfield/ifield
16655  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16656  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
16657  common /mode/eflvl, rflvl
16658  common /cavnum1/xnh, xpas, ffield, npt
16659  common /kcell/avrg(15)
16660  logical ifield
16661 
16662  part = 1.
16663  ifield = .true.
16664  read (20, *) fhc
16665  ! nov02 att=att*(1.+eflvl)
16666  att = atte
16667  read (20, *) xspl(1), yspl(1)
16668  yspl(1) = yspl(1)*att
16669  xspl(1) = xspl(1)*100.
16670  npt = 2
16671  do i = 2, 4000
16672  read (20, *) xspl(i), yspl(i)
16673  if (xspl(i)==0.) go to 10
16674  xspl(i) = xspl(i)*100.
16675  yspl(i) = yspl(i)*att
16676  npt = npt + 1
16677  end do
16678 10 continue
16679  npt = npt - 1
16680  ! **************************************
16681  tdep = xspl(1)
16682  do it = 1, npt
16683  xspl(it) = xspl(it) - tdep
16684  end do
16685  ! **************************************
16686  call deriv2(npt)
16687  xpas = (xspl(3)-xspl(2))/part
16688  xcour = xspl(1)
16689  nfpt = 1
16690  do i = 1, 10000
16691  if (xcour>xspl(npt)) go to 20
16692  yf(i) = spline(npt, xcour)
16693  xf(i) = xcour
16694  xcour = xcour + xpas
16695  nfpt = nfpt + 1
16696  end do
16697 20 continue
16698  ! * valero mars 2006
16699  xlimf = xspl(npt)
16700  xf(nfpt) = 0.
16701  ! omment yf(nfpt)=0.
16702  ! look for the number of cells,the limits of the cells, the number of coordinates in each cell
16703  do i = 1, 15
16704  npoint(i) = 0
16705  end do
16706  ncell = 1
16707  xlim(ncell) = xf(1)
16708  do i = 2, nfpt
16709  if (xf(i)==0.) then
16710  ncell = ncell + 1
16711  xlim(ncell) = xlimf
16712  go to 30
16713  end if
16714  if (yf(i)*yf(i-1)<0.) then
16715  ncell = ncell + 1
16716  xlim(ncell) = xf(i)
16717  else
16718  npoint(ncell) = npoint(ncell) + 1
16719  end if
16720  end do
16721 30 continue
16722  flength = xlim(ncell)
16723  ncell = ncell - 1
16724  ! write(16,*) ' ******Read the field of the cavity************'
16725  write (16, 100) ncell, flength, att, fhc
16726 100 format (' Number of cells: ', i3, ' field length: ', e12.5, 'cm', ' field factor: ', e12.5, ' frequency: ', e12.5, &
16727  ' Hz')
16728  ! ******************************************
16729  ! sv 28/10/2015
16730  call celint
16731  ! *****************************************
16732  do i = 1, ncell
16733  write (16, 200) i, xlim(i), xlim(i+1), avrg(i)
16734  end do
16735 200 format (' Cell number ', i3, ' lower limit ', e12.5, ' cm ', ' upper limit ', e12.5, ' cm ', 'average ', e12.5, &
16736  ' cm')
16737  return
16738  end subroutine fieldcav
16739  ! *******************************************************************
16740  ! SUBROUTINE celint
16741  ! average position in the cell
16742  ! *******************************************************************
16743  subroutine celint
16744  implicit real *8(a-h, o-z)
16745  common /cavnum1/xnh, xpas, fmult, npt
16746  common /consta/vl, pi, xmat, rpel, qst
16747  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
16748  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16749  common /kcell/avrg(15)
16750 
16751  xlpos = 0.
16752  isce = 20
16753  xlcum = 0.
16754  do inc = 1, ncell
16755  xint1 = 0.
16756  xint2 = 0.
16757  xnh = 0.
16758  xlcel = xlim(inc+1) - xlim(inc)
16759  xlpos = xlpos + xlcel
16760  xpas = xlcel/float(isce)
16761  xnhc = 0
16762  estop = xpas/10.
16763  istop = 0
16764 20 continue
16765  xpat = xnhc*xpas
16766  if (xpat<(xlcel-estop)) then
16767  z0 = xnh*xpas
16768  z1 = (xnh+0.20)*xpas
16769  z2 = (xnh+0.40)*xpas
16770  z3 = (xnh+0.60)*xpas
16771  z4 = (xnh+0.80)*xpas
16772  z5 = (xnh+1.00)*xpas
16773  fpos0 = xnh*xpas + xlcum
16774  fpos1 = (xnh+0.20)*xpas + xlcum
16775  fpos2 = (xnh+0.40)*xpas + xlcum
16776  fpos3 = (xnh+0.60)*xpas + xlcum
16777  fpos4 = (xnh+0.80)*xpas + xlcum
16778  fpos5 = (xnh+1.0)*xpas + xlcum
16779  tspl0 = spline(npt, fpos0)
16780  tspl1 = spline(npt, fpos1)
16781  tspl2 = spline(npt, fpos2)
16782  tspl3 = spline(npt, fpos3)
16783  tspl4 = spline(npt, fpos4)
16784  tspl5 = spline(npt, fpos5)
16785  xspl0 = z0*tspl0
16786  xspl1 = z1*tspl1
16787  xspl2 = z2*tspl2
16788  xspl3 = z3*tspl3
16789  xspl4 = z4*tspl4
16790  xspl5 = z5*tspl5
16791  ! integral E(z)*z over the cell
16792  tspl11 = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
16793  xi1 = xpas/288.*tspl11
16794  xint1 = xint1 + xi1
16795  xspl0 = tspl0
16796  xspl1 = tspl1
16797  xspl2 = tspl2
16798  xspl3 = tspl3
16799  xspl4 = tspl4
16800  xspl5 = tspl5
16801  ! integral E(z) over the cell
16802  tspl2 = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
16803  xi2 = xpas/288.*tspl2
16804  xint2 = xint2 + xi2
16805  xnh = xnh + 1.
16806  xnhc = xnhc + 1
16807  go to 20
16808  end if
16809  avrg(inc) = xint1/xint2 + xlcum
16810  xlcum = xlcum + xlcel
16811  end do
16812  return
16813  end subroutine celint
16814  ! *******************************************************************
16815  ! FUNCTION fcav(xc,nrc)
16816  ! electromagnetic field at the position xc
16817  ! *******************************************************************
16818  function fcav(xc, nrc)
16819  implicit real *8(a-h, o-z)
16820  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16821  common /fcv/jsav
16822 
16823  fcav = 0.
16824  if (nrc==1) then
16825  j = 1
16826  else
16827  j = jsav
16828  end if
16829  do k = 1, npoint(nrc)
16830  tk = xc - xf(j)
16831  if (tk==0.) then
16832  fcav = yf(j)
16833  go to 10
16834  end if
16835  if (tk<0.) then
16836  a = (xc-xf(j-1))/(xf(j)-xf(j-1))
16837  b = (xf(j)-xc)/(xf(j)-xf(j-1))
16838  fcav = b*yf(j-1) + a*yf(j)
16839  go to 10
16840  end if
16841  j = j + 1
16842  end do
16843 10 continue
16844  jsav = j
16845  return
16846  end function fcav
16847  ! *******************************************************************
16848  ! FUNCTION ta0(betr,nrc)
16849  ! Transit time factor t(k) (single cell)
16850  ! *******************************************************************
16851  function ta0(betr, nrc)
16852  implicit real *8(a-h, o-z)
16853  common /consta/vl, pi, xmat, rpel, qst
16854  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16855  common /gaus13/h(13), t(13)
16856  common /gaus17/h1(17), t1(17)
16857  common /fcv/jsav
16858 
16859  xk = fhc*2.*pi/(betr*vl)
16860  ar = 0.
16861  xc1 = xlim(nrc)
16862  xc2 = xlim(nrc+1)
16863  do i = 1, 17
16864  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
16865  rfonc = fcav(xc, nrc)
16866  ar = ar + t1(i)*rfonc*cos(xk*xc)
16867  end do
16868  ta0 = ar*(xc2-xc1)
16869  return
16870  end function ta0
16871  ! *******************************************************************
16872  ! FUNCTION tta0(betr)
16873  ! Transit time factor t(k) (multi-cells)
16874  ! *******************************************************************
16875  function tta0(betr)
16876  implicit real *8(a-h, o-z)
16877  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16878  common /consta/vl, pi, xmat, rpel, qst
16879  common /func/a(200), ylg, atte, ncel, nharm
16880  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
16881  common /rfield/ifield
16882  common /gaus13/h(13), t(13)
16883  dimension xmin(15)
16884  logical ifield
16885 
16886  if (ifield) then
16887  tta0 = 0.
16888  do i = 1, ncell
16889  tta0 = tta0 + ta0(betr, i)
16890  end do
16891  else
16892  xk = fh/(betr*vl)
16893  xmin(1) = 0.
16894  do i = 2, ncel + 2
16895  xmin(i) = 0.
16896  end do
16897  do i = 2, ncel + 1
16898  xmin(i) = ylg*(i-1)/ncel
16899  end do
16900  ipas = 1
16901  tta0 = 0.
16902  ar = 0.
16903 101 continue
16904  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
16905  do i = 1, 13
16906  xc1 = xmin(ipas)
16907  xc2 = xmin(ipas+1)
16908  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
16909  rfonc = fone(xc)
16910  ar = ar + h(i)*rfonc*cos(xk*xc)
16911  end do
16912  ar = ar*(xc2-xc1)
16913  tta0 = tta0 + ar
16914  ar = 0.
16915  ipas = ipas + 1
16916  go to 101
16917  end if
16918  return
16919  end function tta0
16920  ! *******************************************************************
16921  ! FUNCTION ta1(betr,nrc)
16922  ! Transit time factor dT(k)/dk (single cell)
16923  ! *******************************************************************
16924  function ta1(betr, nrc)
16925  implicit real *8(a-h, o-z)
16926  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16927  common /consta/vl, pi, xmat, rpel, qst
16928  common /gaus13/h(13), t(13)
16929  common /gaus17/h1(17), t1(17)
16930 
16931  xk = fhc*2.*pi/(betr*vl)
16932  ar = 0.
16933  xc1 = xlim(nrc)
16934  xc2 = xlim(nrc+1)
16935  do i = 1, 17
16936  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
16937  rfonc = fcav(xc, nrc)
16938  ar = ar - t1(i)*xc*rfonc*sin(xk*xc)
16939  end do
16940  ta1 = ar*(xc2-xc1)
16941  return
16942  end function ta1
16943  ! *******************************************************************
16944  ! FUNCTION tta1(BETR)
16945  ! Transit time factor dT(k)/dk (multi-cells)
16946  ! *******************************************************************
16947  function tta1(betr)
16948  implicit real *8(a-h, o-z)
16949  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16950  common /consta/vl, pi, xmat, rpel, qst
16951  common /func/a(200), ylg, atte, ncel, nharm
16952  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
16953  common /rfield/ifield
16954  common /gaus13/h(13), t(13)
16955  dimension xmin(15)
16956  logical ifield
16957 
16958  if (ifield) then
16959  tta1 = 0.
16960  do i = 1, ncell
16961  tta1 = tta1 + ta1(betr, i)
16962  end do
16963  return
16964  else
16965  xk = fh/(betr*vl)
16966  xmin(1) = 0.
16967  do i = 2, ncel + 2
16968  xmin(i) = 0.
16969  end do
16970  do i = 2, ncel + 1
16971  xmin(i) = ylg*(i-1)/ncel
16972  end do
16973  ipas = 1
16974  tta1 = 0.
16975  ar = 0.
16976 101 continue
16977  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
16978  do i = 1, 13
16979  xc1 = xmin(ipas)
16980  xc2 = xmin(ipas+1)
16981  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
16982  rfonc = fone(xc)
16983  ar = ar - h(i)*xc*rfonc*sin(xk*xc)
16984  end do
16985  ar = ar*(xc2-xc1)
16986  tta1 = tta1 + ar
16987  ar = 0.
16988  ipas = ipas + 1
16989  go to 101
16990  end if
16991  end function tta1
16992  ! *******************************************************************
16993  ! FUNCTION ta2(betr,nrc)
16994  ! Transit time factor d2T(k)/dk2 (single cell)
16995  ! *******************************************************************
16996  function ta2(betr, nrc)
16997  implicit real *8(a-h, o-z)
16998  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
16999  common /consta/vl, pi, xmat, rpel, qst
17000  common /gaus13/h(13), t(13)
17001  common /gaus17/h1(17), t1(17)
17002 
17003  xk = fhc*2.*pi/(betr*vl)
17004  ar = 0.
17005  xc1 = xlim(nrc)
17006  xc2 = xlim(nrc+1)
17007  do i = 1, 17
17008  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17009  rfonc = fcav(xc, nrc)
17010  ar = ar - t1(i)*xc*xc*rfonc*cos(xk*xc)
17011  end do
17012  ta2 = ar*(xc2-xc1)
17013  return
17014  end function ta2
17015  ! *******************************************************************
17016  ! FUNCTION tta2(BETR)
17017  ! Transit time factor d2T(k)/dk2 (multi-cells)
17018  ! *******************************************************************
17019  function tta2(betr)
17020  implicit real *8(a-h, o-z)
17021  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17022  common /consta/vl, pi, xmat, rpel, qst
17023  common /func/a(200), ylg, atte, ncel, nharm
17024  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17025  common /rfield/ifield
17026  common /gaus13/h(13), t(13)
17027  dimension xmin(15)
17028  logical ifield
17029 
17030  if (ifield) then
17031  tta2 = 0.
17032  do i = 1, ncell
17033  tta2 = tta2 + ta2(betr, i)
17034  end do
17035  return
17036  else
17037  xk = fh/(betr*vl)
17038  xmin(1) = 0.
17039  do i = 2, ncel + 2
17040  xmin(i) = 0.
17041  end do
17042  do i = 2, ncel + 1
17043  xmin(i) = ylg*(i-1)/ncel
17044  end do
17045  ipas = 1
17046  tta2 = 0.
17047  ar = 0.
17048 101 continue
17049  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17050  do i = 1, 13
17051  xc1 = xmin(ipas)
17052  xc2 = xmin(ipas+1)
17053  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17054  rfonc = fone(xc)
17055  ar = ar - h(i)*xc*xc*rfonc*cos(xk*xc)
17056  end do
17057  ar = ar*(xc2-xc1)
17058  tta2 = tta2 + ar
17059  ar = 0.
17060  ipas = ipas + 1
17061  go to 101
17062  end if
17063  end function tta2
17064  ! *******************************************************************
17065  ! FUNCTION ta3(betr,nrc)
17066  ! Transit time factor d3T(k)/dk3 (single cell)
17067  ! *******************************************************************
17068  function ta3(betr, nrc)
17069  implicit real *8(a-h, o-z)
17070  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17071  common /consta/vl, pi, xmat, rpel, qst
17072  common /gaus13/h(13), t(13)
17073  common /gaus17/h1(17), t1(17)
17074 
17075  xk = fhc*2.*pi/(betr*vl)
17076  ar = 0.
17077  xc1 = xlim(nrc)
17078  xc2 = xlim(nrc+1)
17079  do i = 1, 17
17080  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17081  rfonc = fcav(xc, nrc)
17082  ar = ar + t1(i)*xc*xc*xc*rfonc*sin(xk*xc)
17083  end do
17084  ta3 = ar*(xc2-xc1)
17085  return
17086  end function ta3
17087  ! *******************************************************************
17088  ! FUNCTION tta3(BETR)
17089  ! Transit time factor d3T(k)/dk2 (multi-cells)
17090  ! *******************************************************************
17091  function tta3(betr)
17092  implicit real *8(a-h, o-z)
17093  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17094  common /consta/vl, pi, xmat, rpel, qst
17095  common /func/a(200), ylg, atte, ncel, nharm
17096  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17097  common /rfield/ifield
17098  common /gaus13/h(13), t(13)
17099  dimension xmin(15)
17100  logical ifield
17101 
17102  if (ifield) then
17103  tta3 = 0.
17104  do i = 1, ncell
17105  tta3 = tta3 + ta3(betr, i)
17106  end do
17107  return
17108  else
17109  xk = fh/(betr*vl)
17110  xmin(1) = 0.
17111  do i = 2, ncel + 2
17112  xmin(i) = 0.
17113  end do
17114  do i = 2, ncel + 1
17115  xmin(i) = ylg*(i-1)/ncel
17116  end do
17117  ipas = 1
17118  tta3 = 0.
17119  ar = 0.
17120 101 continue
17121  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17122  do i = 1, 13
17123  xc1 = xmin(ipas)
17124  xc2 = xmin(ipas+1)
17125  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17126  rfonc = fone(xc)
17127  ar = ar + h(i)*xc*xc*xc*rfonc*sin(xk*xc)
17128  end do
17129  ar = ar*(xc2-xc1)
17130  tta3 = tta3 + ar
17131  ar = 0.
17132  ipas = ipas + 1
17133  go to 101
17134  end if
17135  end function tta3
17136  ! *******************************************************************
17137  ! FUNCTION ta4(betr,nrc)
17138  ! Transit time factor d4T(k)/dk4 (single cell)
17139  ! *******************************************************************
17140  function ta4(betr, nrc)
17141  implicit real *8(a-h, o-z)
17142  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17143  common /consta/vl, pi, xmat, rpel, qst
17144  common /gaus13/h(13), t(13)
17145  common /gaus17/h1(17), t1(17)
17146 
17147  xk = fhc*2.*pi/(betr*vl)
17148  ar = 0.
17149  xc1 = xlim(nrc)
17150  xc2 = xlim(nrc+1)
17151  do i = 1, 17
17152  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17153  rfonc = fcav(xc, nrc)
17154  ar = ar + t1(i)*xc**4*rfonc*cos(xk*xc)
17155  end do
17156  ta4 = ar*(xc2-xc1)
17157  return
17158  end function ta4
17159  ! *******************************************************************
17160  ! FUNCTION tta4(BETR)
17161  ! Transit time factor d4T(k)/dk4 (multi-cells)
17162  ! *******************************************************************
17163  function tta4(betr)
17164  implicit real *8(a-h, o-z)
17165  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17166  common /consta/vl, pi, xmat, rpel, qst
17167  common /func/a(200), ylg, atte, ncel, nharm
17168  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17169  common /rfield/ifield
17170  common /gaus13/h(13), t(13)
17171  dimension xmin(15)
17172  logical ifield
17173 
17174  if (ifield) then
17175  tta4 = 0.
17176  do i = 1, ncell
17177  tta4 = tta4 + ta4(betr, i)
17178  end do
17179  return
17180  else
17181  xk = fh/(betr*vl)
17182  xmin(1) = 0.
17183  do i = 2, ncel + 2
17184  xmin(i) = 0.
17185  end do
17186  do i = 2, ncel + 1
17187  xmin(i) = ylg*(i-1)/ncel
17188  end do
17189  ipas = 1
17190  tta4 = 0.
17191  ar = 0.
17192 101 continue
17193  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17194  do i = 1, 13
17195  xc1 = xmin(ipas)
17196  xc2 = xmin(ipas+1)
17197  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17198  rfonc = fone(xc)
17199  ar = ar + h(i)*xc**4*rfonc*cos(xk*xc)
17200  end do
17201  ar = ar*(xc2-xc1)
17202  tta4 = tta4 + ar
17203  ar = 0.
17204  ipas = ipas + 1
17205  go to 101
17206  end if
17207  end function tta4
17208  ! *******************************************************************
17209  ! FUNCTION ta5(betr,nrc)
17210  ! Transit time factor d5T(k)/dk5 (single cell)
17211  ! *******************************************************************
17212  function ta5(betr, nrc)
17213  implicit real *8(a-h, o-z)
17214  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17215  common /consta/vl, pi, xmat, rpel, qst
17216  common /gaus13/h(13), t(13)
17217  common /gaus17/h1(17), t1(17)
17218 
17219  xk = fhc*2.*pi/(betr*vl)
17220  ar = 0.
17221  xc1 = xlim(nrc)
17222  xc2 = xlim(nrc+1)
17223  do i = 1, 17
17224  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17225  rfonc = fcav(xc, nrc)
17226  ar = ar - t1(i)*xc**5*rfonc*sin(xk*xc)
17227  end do
17228  ta5 = ar*(xc2-xc1)
17229  return
17230  end function ta5
17231  ! *******************************************************************
17232  ! FUNCTION tta5(BETR)
17233  ! Transit time factor d5T(k)/dk5 (multi-cells)
17234  ! *******************************************************************
17235  function tta5(betr)
17236  implicit real *8(a-h, o-z)
17237  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17238  common /consta/vl, pi, xmat, rpel, qst
17239  common /func/a(200), ylg, atte, ncel, nharm
17240  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17241  common /rfield/ifield
17242  common /gaus13/h(13), t(13)
17243  dimension xmin(15)
17244  logical ifield
17245 
17246  if (ifield) then
17247  tta5 = 0.
17248  do i = 1, ncell
17249  tta5 = tta5 + ta5(betr, i)
17250  end do
17251  return
17252  else
17253  xk = fh/(betr*vl)
17254  xmin(1) = 0.
17255  do i = 2, ncel + 2
17256  xmin(i) = 0.
17257  end do
17258  do i = 2, ncel + 1
17259  xmin(i) = ylg*(i-1)/ncel
17260  end do
17261  ipas = 1
17262  tta5 = 0.
17263  ar = 0.
17264 101 continue
17265  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17266  do i = 1, 13
17267  xc1 = xmin(ipas)
17268  xc2 = xmin(ipas+1)
17269  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17270  rfonc = fone(xc)
17271  ar = ar - h(i)*xc**5*rfonc*sin(xk*xc)
17272  end do
17273  ar = ar*(xc2-xc1)
17274  tta5 = tta5 + ar
17275  ar = 0.
17276  ipas = ipas + 1
17277  go to 101
17278  end if
17279  end function tta5
17280  ! *******************************************************************
17281  ! FUNCTION sb0(BETR,nrc)
17282  ! Transit time factor s(k) (single cell)
17283  ! *******************************************************************
17284  function sb0(betr, nrc)
17285  implicit real *8(a-h, o-z)
17286  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17287  common /consta/vl, pi, xmat, rpel, qst
17288  common /gaus13/h(13), t(13)
17289  common /gaus17/h1(17), t1(17)
17290 
17291  xk = fhc*2.*pi/(betr*vl)
17292  xc1 = xlim(nrc)
17293  xc2 = xlim(nrc+1)
17294  br = 0.
17295  do i = 1, 17
17296  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17297  rfonc = fcav(xc, nrc)
17298  br = br + t1(i)*rfonc*sin(xk*xc)
17299  end do
17300  sb0 = br*(xc2-xc1)
17301  return
17302  end function sb0
17303  ! *******************************************************************
17304  ! FUNCTION tsb0(BETR)
17305  ! Transit time factor s(k) (multi-cells)
17306  ! *******************************************************************
17307  function tsb0(betr)
17308  implicit real *8(a-h, o-z)
17309  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17310  common /consta/vl, pi, xmat, rpel, qst
17311  common /func/a(200), ylg, atte, ncel, nharm
17312  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17313  common /rfield/ifield
17314  common /gaus13/h(13), t(13)
17315  dimension xmin(15)
17316  logical ifield
17317 
17318  if (ifield) then
17319  tsb0 = 0.
17320  do i = 1, ncell
17321  tsb0 = tsb0 + sb0(betr, i)
17322  end do
17323  return
17324  else
17325  xk = fh/(betr*vl)
17326  xmin(1) = 0.
17327  do i = 2, ncel + 2
17328  xmin(i) = 0.
17329  end do
17330  do i = 2, ncel + 1
17331  xmin(i) = ylg*(i-1)/ncel
17332  end do
17333  ipas = 1
17334  tsb0 = 0.
17335  br = 0.
17336 101 continue
17337  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17338  do i = 1, 13
17339  xc1 = xmin(ipas)
17340  xc2 = xmin(ipas+1)
17341  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17342  rfonc = fone(xc)
17343  br = br + h(i)*rfonc*sin(xk*xc)
17344  end do
17345  br = br*(xc2-xc1)
17346  tsb0 = tsb0 + br
17347  br = 0.
17348  ipas = ipas + 1
17349  go to 101
17350  end if
17351  end function tsb0
17352  ! *******************************************************************
17353  ! FUNCTION sb1(BETR,nrc)
17354  ! Transit time factor dS(k)/dk (single cell)
17355  ! *******************************************************************
17356  function sb1(betr, nrc)
17357  implicit real *8(a-h, o-z)
17358  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17359  common /consta/vl, pi, xmat, rpel, qst
17360  common /gaus13/h(13), t(13)
17361  common /gaus17/h1(17), t1(17)
17362 
17363  xk = fhc*2.*pi/(betr*vl)
17364  xc1 = xlim(nrc)
17365  xc2 = xlim(nrc+1)
17366  br = 0.
17367  do i = 1, 17
17368  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17369  rfonc = fcav(xc, nrc)
17370  br = br + t1(i)*xc*rfonc*cos(xk*xc)
17371  end do
17372  sb1 = br*(xc2-xc1)
17373  return
17374  end function sb1
17375  ! *******************************************************************
17376  ! FUNCTION tsb1(BETR)
17377  ! Transit time factor ds(k)/dk (multi-cells)
17378  ! *******************************************************************
17379  function tsb1(betr)
17380  implicit real *8(a-h, o-z)
17381  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17382  common /consta/vl, pi, xmat, rpel, qst
17383  common /func/a(200), ylg, atte, ncel, nharm
17384  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17385  common /rfield/ifield
17386  common /gaus13/h(13), t(13)
17387  dimension xmin(15)
17388  logical ifield
17389 
17390  if (ifield) then
17391  tsb1 = 0.
17392  do i = 1, ncell
17393  tsb1 = tsb1 + sb1(betr, i)
17394  end do
17395  return
17396  else
17397  xk = fh/(betr*vl)
17398  xmin(1) = 0.
17399  do i = 2, ncel + 2
17400  xmin(i) = 0.
17401  end do
17402  do i = 2, ncel + 1
17403  xmin(i) = ylg*(i-1)/ncel
17404  end do
17405  ipas = 1
17406  tsb1 = 0.
17407  br = 0.
17408 101 continue
17409  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17410  do i = 1, 13
17411  xc1 = xmin(ipas)
17412  xc2 = xmin(ipas+1)
17413  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17414  rfonc = fone(xc)
17415  br = br + h(i)*xc*rfonc*cos(xk*xc)
17416  end do
17417  br = br*(xc2-xc1)
17418  tsb1 = tsb1 + br
17419  br = 0.
17420  ipas = ipas + 1
17421  go to 101
17422  end if
17423  end function tsb1
17424  ! *******************************************************************
17425  ! FUNCTION sb2(BETR,nrc)
17426  ! Transit time factor d2S(k)/dk2 (single cell)
17427  ! *******************************************************************
17428  function sb2(betr, nrc)
17429  implicit real *8(a-h, o-z)
17430  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17431  common /consta/vl, pi, xmat, rpel, qst
17432  common /gaus13/h(13), t(13)
17433  common /gaus17/h1(17), t1(17)
17434 
17435  xk = fhc*2.*pi/(betr*vl)
17436  xc1 = xlim(nrc)
17437  xc2 = xlim(nrc+1)
17438  br = 0.
17439  do i = 1, 17
17440  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17441  rfonc = fcav(xc, nrc)
17442  br = br - t1(i)*xc*xc*rfonc*sin(xk*xc)
17443  end do
17444  sb2 = br*(xc2-xc1)
17445  return
17446  end function sb2
17447  ! *******************************************************************
17448  ! FUNCTION tsb2(BETR)
17449  ! Transit time factor d2S(k)/dk2 (multi-cells)
17450  ! *******************************************************************
17451  function tsb2(betr)
17452  implicit real *8(a-h, o-z)
17453  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17454  common /consta/vl, pi, xmat, rpel, qst
17455  common /func/a(200), ylg, atte, ncel, nharm
17456  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17457  common /rfield/ifield
17458  common /gaus13/h(13), t(13)
17459  dimension xmin(15)
17460  logical ifield
17461 
17462  if (ifield) then
17463  tsb2 = 0.
17464  do i = 1, ncell
17465  tsb2 = tsb2 + sb2(betr, i)
17466  end do
17467  return
17468  else
17469  xk = fh/(betr*vl)
17470  xmin(1) = 0.
17471  do i = 2, ncel + 2
17472  xmin(i) = 0.
17473  end do
17474  do i = 2, ncel + 1
17475  xmin(i) = ylg*(i-1)/ncel
17476  end do
17477  ipas = 1
17478  tsb2 = 0.
17479  br = 0.
17480 101 continue
17481  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17482  do i = 1, 13
17483  xc1 = xmin(ipas)
17484  xc2 = xmin(ipas+1)
17485  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17486  rfonc = fone(xc)
17487  br = br - h(i)*xc*xc*rfonc*sin(xk*xc)
17488  end do
17489  br = br*(xc2-xc1)
17490  tsb2 = tsb2 + br
17491  br = 0.
17492  ipas = ipas + 1
17493  go to 101
17494  end if
17495  end function tsb2
17496  ! *******************************************************************
17497  ! FUNCTION sb3(BETR,nrc)
17498  ! Transit time factor d3S(k)/dk3 (single cell)
17499  ! *******************************************************************
17500  function sb3(betr, nrc)
17501  implicit real *8(a-h, o-z)
17502  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17503  common /consta/vl, pi, xmat, rpel, qst
17504  common /gaus13/h(13), t(13)
17505  common /gaus17/h1(17), t1(17)
17506 
17507  xk = fhc*2.*pi/(betr*vl)
17508  xc1 = xlim(nrc)
17509  xc2 = xlim(nrc+1)
17510  br = 0.
17511  do i = 1, 17
17512  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17513  rfonc = fcav(xc, nrc)
17514  br = br - t1(i)*xc*xc*xc*rfonc*cos(xk*xc)
17515  end do
17516  sb3 = br*(xc2-xc1)
17517  return
17518  end function sb3
17519  ! *******************************************************************
17520  ! FUNCTION tsb3(BETR)
17521  ! Transit time factor d3S(k)/dk3 (multi-cells)
17522  ! *******************************************************************
17523  function tsb3(betr)
17524  implicit real *8(a-h, o-z)
17525  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17526  common /consta/vl, pi, xmat, rpel, qst
17527  common /func/a(200), ylg, atte, ncel, nharm
17528  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17529  common /rfield/ifield
17530  common /gaus13/h(13), t(13)
17531  dimension xmin(15)
17532  logical ifield
17533 
17534  if (ifield) then
17535  tsb3 = 0.
17536  do i = 1, ncell
17537  tsb3 = tsb3 + sb3(betr, i)
17538  end do
17539  return
17540  else
17541  xk = fh/(betr*vl)
17542  xmin(1) = 0.
17543  do i = 2, ncel + 2
17544  xmin(i) = 0.
17545  end do
17546  do i = 2, ncel + 1
17547  xmin(i) = ylg*(i-1)/ncel
17548  end do
17549  ipas = 1
17550  tsb3 = 0.
17551  br = 0.
17552 101 continue
17553  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17554  do i = 1, 13
17555  xc1 = xmin(ipas)
17556  xc2 = xmin(ipas+1)
17557  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17558  rfonc = fone(xc)
17559  br = br - h(i)*xc*xc*xc*rfonc*cos(xk*xc)
17560  end do
17561  br = br*(xc2-xc1)
17562  tsb3 = tsb3 + br
17563  br = 0.
17564  ipas = ipas + 1
17565  go to 101
17566  end if
17567  end function tsb3
17568  ! *******************************************************************
17569  ! FUNCTION sb4(BETR,nrc)
17570  ! Transit time factor d4S(k)/dk5 (single cell)
17571  ! *******************************************************************
17572  function sb4(betr, nrc)
17573  implicit real *8(a-h, o-z)
17574  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17575  common /consta/vl, pi, xmat, rpel, qst
17576  common /gaus13/h(13), t(13)
17577  common /gaus17/h1(17), t1(17)
17578 
17579  xk = fhc*2.*pi/(betr*vl)
17580  xc1 = xlim(nrc)
17581  xc2 = xlim(nrc+1)
17582  br = 0.
17583  do i = 1, 17
17584  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17585  rfonc = fcav(xc, nrc)
17586  br = br + t1(i)*xc**4*rfonc*sin(xk*xc)
17587  end do
17588  sb4 = br*(xc2-xc1)
17589  return
17590  end function sb4
17591  ! *******************************************************************
17592  ! FUNCTION tsb4(BETR)
17593  ! Transit time factor d4S(k)/dk5 (multi cells)
17594  ! *******************************************************************
17595  function tsb4(betr)
17596  implicit real *8(a-h, o-z)
17597  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17598  common /consta/vl, pi, xmat, rpel, qst
17599  common /func/a(200), ylg, atte, ncel, nharm
17600  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17601  common /rfield/ifield
17602  common /gaus13/h(13), t(13)
17603  dimension xmin(15)
17604  logical ifield
17605 
17606  if (ifield) then
17607  tsb4 = 0.
17608  do i = 1, ncell
17609  tsb4 = tsb4 + sb4(betr, i)
17610  end do
17611  return
17612  else
17613  xk = fh/(betr*vl)
17614  xmin(1) = 0.
17615  do i = 2, ncel + 2
17616  xmin(i) = 0.
17617  end do
17618  do i = 2, ncel + 1
17619  xmin(i) = ylg*(i-1)/ncel
17620  end do
17621  ipas = 1
17622  tsb4 = 0.
17623  br = 0.
17624 101 continue
17625  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17626  do i = 1, 13
17627  xc1 = xmin(ipas)
17628  xc2 = xmin(ipas+1)
17629  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17630  rfonc = fone(xc)
17631  br = br + h(i)*xc**4*rfonc*sin(xk*xc)
17632  end do
17633  br = br*(xc2-xc1)
17634  tsb4 = tsb4 + br
17635  br = 0.
17636  ipas = ipas + 1
17637  go to 101
17638  end if
17639  end function tsb4
17640  ! *******************************************************************
17641  ! FUNCTION sb5(BETR,nrc)
17642  ! Transit time factor d5S(k)/dk5 (single cell)
17643  ! *******************************************************************
17644  function sb5(betr, nrc)
17645  implicit real *8(a-h, o-z)
17646  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17647  common /consta/vl, pi, xmat, rpel, qst
17648  common /gaus13/h(13), t(13)
17649  common /gaus17/h1(17), t1(17)
17650 
17651  xk = fhc*2.*pi/(betr*vl)
17652  xc1 = xlim(nrc)
17653  xc2 = xlim(nrc+1)
17654  br = 0.
17655  do i = 1, 17
17656  xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
17657  rfonc = fcav(xc, nrc)
17658  br = br + t1(i)*xc**5*rfonc*cos(xk*xc)
17659  end do
17660  sb5 = br*(xc2-xc1)
17661  return
17662  end function sb5
17663  ! *******************************************************************
17664  ! FUNCTION tsb5(BETR)
17665  ! Transit time factor d5S(k)/dk5
17666  ! *******************************************************************
17667  function tsb5(betr)
17668  implicit real *8(a-h, o-z)
17669  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
17670  common /consta/vl, pi, xmat, rpel, qst
17671  common /func/a(200), ylg, atte, ncel, nharm
17672  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17673  common /rfield/ifield
17674  common /gaus13/h(13), t(13)
17675  dimension xmin(15)
17676  logical ifield
17677 
17678  if (ifield) then
17679  tsb5 = 0.
17680  do i = 1, ncell
17681  tsb5 = tsb5 + sb5(betr, i)
17682  end do
17683  return
17684  else
17685  xk = fh/(betr*vl)
17686  xmin(1) = 0.
17687  do i = 2, ncel + 2
17688  xmin(i) = 0.
17689  end do
17690  do i = 2, ncel + 1
17691  xmin(i) = ylg*(i-1)/ncel
17692  end do
17693  ipas = 1
17694  tsb5 = 0.
17695  br = 0.
17696 101 continue
17697  if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
17698  do i = 1, 13
17699  xc1 = xmin(ipas)
17700  xc2 = xmin(ipas+1)
17701  xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
17702  rfonc = fone(xc)
17703  br = br + h(i)*xc**5*rfonc*cos(xk*xc)
17704  end do
17705  br = br*(xc2-xc1)
17706  tsb5 = tsb5 + br
17707  br = 0.
17708  ipas = ipas + 1
17709  go to 101
17710  end if
17711  end function tsb5
17712  ! *******************************************************************
17713  ! FUNCTION fone(Z)
17714  ! Electromagnetic field at the longitudinal point (z,0)
17715  ! The field harmonics are stored in A(200)
17716  ! *******************************************************************
17717  function fone(z)
17718  implicit real *8(a-h, o-z)
17719  common /consta/vl, pi, xmat, rpel, qst
17720  common /func/a(200), ylg, atte, ncel, nharm
17721  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17722 
17723  fone = 0.
17724  do j = 1, nharm
17725  xl = pi*(j-1)/ylg
17726  fone = fone + a(j)*cos(xl*z)
17727  end do
17728  return
17729  end function fone
17730  ! *******************************************************************
17731  ! SUBROUTINE rharm
17732  ! the field is in the form of a Fourier series expansion
17733  ! *******************************************************************
17734  subroutine rharm
17735  implicit real *8(a-h, o-z)
17736  common /func/a(200), ylg, atte, ncel, nharm
17737  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
17738  common /tapes/in, ifile, meta
17739  common /consta/vl, pi, xmat, rpel, qst
17740  common /rfield/ifield
17741  common /mode/eflvl, rflvl
17742  logical ifield
17743 
17744  ifield = .false.
17745  ! ylg: length of the field (cm)
17746  ! fh: frequency (hertz)
17747  ! atte: field factor
17748  ! ncel: number of cells in the cavity
17749  read (in, *) ylg, fh, atte, ncel
17750  read (in, *) nharm
17751  read (in, *)(a(i), i=1, nharm)
17752  write (16, 100) ncel, ylg, fh, atte
17753 100 format (' number of cells in the cavity: ', i3, /, ' field length: ', e12.5, 'cm', /, ' freq. ', e12.5, ' Hertz', &
17754  ' field factor ', e12.5)
17755  write (16, *) ' number of harmonics: ', nharm
17756  write (16, 200)(a(i), i=1, nharm)
17757 200 format (3(2x,e12.5))
17758  do i = 1, nharm
17759  a(i) = a(i)*atte
17760  end do
17761  fh = fh*2.*pi
17762  ! **********************************************
17763  ! sv 24/10/2015
17764  xp = ylg/100.
17765  open (18, file='chemtr.txt', status='unknown')
17766  zx = 0.
17767  yh = 0.
17768 98 continue
17769  do inh = 1, nharm
17770  ! c xl=pi*float(inh-1)/ylg
17771  ! c yh=yh+a(inh)*cos(xl*zx)
17772  ff = fone(zx)
17773  end do
17774  write (18, 99) zx/100., ff
17775 99 format (3(2x,e12.5))
17776  zx = zx + xp
17777  if (zx<ylg) go to 98
17778  close (18)
17779  ! **********************************************
17780  return
17781  end subroutine rharm
17782  ! *******************************************************************
17783  ! SUBROUTINE profil
17784  ! Store header and envelopes in a binary file for
17785  ! graphics post-processor
17786  ! *******************************************************************
17787  subroutine profil
17788  implicit real *8(a-h, o-z)
17789  common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
17790  common /tapes/in, ifile, meta
17791 
17792  call plprf1
17793  call plprf2
17794  return
17795  end subroutine profil
17796  ! *******************************************************************
17797  ! SUBROUTINE plprf1
17798  ! IPRF : POINTEUR
17799  ! RMSN :envelope size in multiples of RMS size
17800  ! SPRFX :half horizontal extent (cm)
17801  ! SPRFY :half vertical extent (cm)
17802  ! SPRFW :half energy extent (MeV)
17803  ! SPRFP :half phase extent (deg)
17804  ! SPRFL :position along Z(m)
17805  ! *******************************************************************
17806  subroutine plprf1
17807  implicit real *8(a-h, o-z)
17808  dimension xx(3000), yy(3000)
17809  ! RMSN :envelope size in multiples of RMS size
17810  ! ZDEB : Starting position of the plot
17811  ! ZFIN : End of the plot
17812  character *80 car, text
17813  common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
17814  common /pltprf/sprfy(3000), sprfz(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
17815  common /tapes/in, ifile, meta
17816  common /prof/car
17817 
17818  read (in, 69) car(1:80)
17819 69 format (a80)
17820  read (in, *) rmsn
17821  read (in, *) zdeb, zfin
17822  read (in, *) xxmax, xymax, ywmax, ypmax
17823  iprf = iprf - 1
17824  ideb = 1
17825  ifin = iprf
17826  if (zfin>sprfl(iprf)) zfin = sprfl(iprf)
17827  write (16, *) ' ******* PROFIL ***************** '
17828  write (16, *) ' IPRF ZFIN ', iprf, zfin
17829  do i = 2, iprf
17830  if ((zdeb>sprfl(i-1)) .and. (zdeb<=sprfl(i))) ideb = i
17831  if ((zfin>=sprfl(i-1)) .and. (zfin<sprfl(i))) ifin = i - 1
17832  end do
17833  if (xxmax<=0.) then
17834  xxmax = 0.
17835  do i = ideb, ifin
17836  if (0.5*sprfy(i)*rmsn>xxmax) xxmax = 0.5*sprfy(i)*rmsn
17837  end do
17838  end if
17839  if (xymax<=0.) then
17840  xymax = 0.
17841  do i = ideb, ifin
17842  if (0.5*sprfz(i)*rmsn>xymax) xymax = 0.5*sprfz(i)*rmsn
17843  end do
17844  end if
17845  ! Store header and envelopes in binary file for
17846  ! graphics post-processor
17847 
17848  ! igrtyp is type of graph (igrtyp=3 for x,y envelope plots)
17849  igrtyp = 3
17850  text = 'X and Y envelopes '
17851  text(21:80) = car(1:60)
17852  write (66, *) igrtyp
17853  write (66, *) text
17854  xx(1) = zdeb
17855  xx(2) = zfin
17856  yy(1) = -xymax
17857  yy(2) = xxmax
17858  write (16, *) ' XMAX YMAX ', xxmax, xymax
17859  write (66, *) xx(1), xx(2), yy(1), yy(2)
17860  ! GRADX=XXMAX/3.
17861  ! YFAXE=XXMAX
17862  icnt = 0
17863  do i = ideb, ifin
17864  icnt = icnt + 1
17865  xx(icnt) = sprfl(i)
17866  yy(icnt) = 0.5*sprfy(i)*rmsn
17867  end do
17868  ! write envelope coordinates to graphics file
17869  write (66, *) icnt
17870  do i = 1, icnt
17871  write (66, *) xx(i), yy(i)
17872  end do
17873  icnt = 0
17874  do i = ideb, ifin
17875  icnt = icnt + 1
17876  xx(icnt) = sprfl(i)
17877  yy(icnt) = -0.5*sprfz(i)*rmsn
17878  end do
17879  ! write envelope coordinates to graphics file
17880  write (66, *) icnt
17881  do i = 1, icnt
17882  write (66, *) xx(i), yy(i)
17883  end do
17884  return
17885  end subroutine plprf1
17886  ! *******************************************************************
17887  ! SUBROUTINE plprf2
17888  ! Store header and envelopes in binary file for
17889  ! graphics post-processor
17890  ! *******************************************************************
17891  subroutine plprf2
17892  implicit real *8(a-h, o-z)
17893  dimension xx(3000), yy(3000)
17894  character *80 car, text
17895  common /prof/car
17896  common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
17897  common /pltprf/sprfy(3000), sprfz(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
17898 
17899  ideb = 1
17900  ifin = iprf
17901  do i = 2, iprf
17902  if ((zdeb>sprfl(i-1)) .and. (zdeb<=sprfl(i))) ideb = i
17903  if ((zfin>=sprfl(i-1)) .and. (zfin<sprfl(i))) ifin = i - 1
17904  end do
17905  xxmax = ywmax/1000.
17906  xymax = ypmax
17907  if (xxmax<=0.) then
17908  xxmax = 0.
17909  do i = ideb, ifin
17910  if (0.5*sprfw(i)*rmsn>xxmax) xxmax = 0.5*sprfw(i)*rmsn
17911  end do
17912  end if
17913  if (xymax<=0.) then
17914  xymax = 0.
17915  do i = ideb, ifin
17916  if (0.5*sprfp(i)*rmsn>xymax) xymax = 0.5*sprfp(i)*rmsn
17917  end do
17918  end if
17919  ! Store header and envelopes in binary file for
17920  ! graphics post-processor
17921 
17922  ! igrtyp is type of graph (igrtyp=4 for dW/W envelope plots)
17923  igrtyp = 4
17924  text = 'dW/W envelope '
17925  text(21:80) = car(1:60)
17926  write (66, *) igrtyp
17927  write (66, *) text
17928  xx(1) = zdeb
17929  xx(2) = zfin
17930  yy(1) = 0.
17931  yy(2) = xxmax*1000.
17932  write (66, *) xx(1), xx(2), yy(1), yy(2)
17933  icnt = 0
17934  do i = ideb, ifin
17935  icnt = icnt + 1
17936  xx(icnt) = sprfl(i)
17937  yy(icnt) = 0.5*sprfw(i)*1000.*rmsn
17938  end do
17939  ! write envelope coordinates to graphics file
17940  write (66, *) icnt
17941  do i = 1, icnt
17942  write (66, *) xx(i), yy(i)
17943  end do
17944  ! Store header and envelopes in binary file for
17945  ! graphics post-processor
17946 
17947  ! igrtyp is type of graph (igrtyp=5 for dPHI envelope plots)
17948  igrtyp = 5
17949  text = 'dPHI envelope '
17950  text(21:80) = car(1:60)
17951  write (66, *) igrtyp
17952  write (66, *) text
17953  xx(1) = zdeb
17954  xx(2) = zfin
17955  ! 14/08/2009 yy(1)=-xymax
17956  yy(1) = 0.
17957  yy(2) = xymax
17958  write (16, *) ' dW/WMAX dPhiMAX ', xxmax, xymax
17959  write (66, *) xx(1), xx(2), yy(1), yy(2)
17960  icnt = 0
17961  do i = ideb, ifin
17962  icnt = icnt + 1
17963  xx(icnt) = sprfl(i)
17964  yy(icnt) = 0.5*sprfp(i)*rmsn
17965  end do
17966  ! write envelope coordinates to graphics file
17967  write (66, *) icnt
17968  do i = 1, icnt
17969  write (66, *) xx(i), yy(i)
17970  end do
17971  iprf = iprf + 1
17972  return
17973  end subroutine plprf2
17974  ! *******************************************************************
17975  ! FUNCTION slope(N,XV)
17976  ! first derivative of the spline function
17977  ! *******************************************************************
17978  function slope(n, xv)
17979  implicit real *8(a-h, o-z)
17980  common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
17981 
17982  do i = 2, n
17983  xtvi = xv - x(i)
17984  if (xtvi>0.) go to 4
17985  if (xtvi<0.) go to 2
17986  if (xtvi==0.00) go to 3
17987 4 continue
17988  end do
17989 3 i = i - 1
17990  avx = x(i+1) - x(i)
17991  slope = s(i+1)*avx/3. + s(i)*avx/6. + (y(i+1)-y(i))/avx
17992  return
17993 2 i = i - 1
17994  dgx = xv - x(i)
17995  ddx = x(i+1) - xv
17996  avx = x(i+1) - x(i)
17997  slope = -(s(i)*ddx*ddx)/(2.*avx) + (s(i+1)*dgx*dgx)/(2.*avx) + ((y(i+1)-y(i))/avx) - (avx*(s(i+1)-s(i))/6.)
17998  return
17999  end function slope
18000  ! *******************************************************************
18001  ! FUNCTION spline (N,XV)
18002  ! SPLINE FUNCTION
18003  ! *******************************************************************
18004  function spline(n, xv)
18005  implicit real *8(a-h, o-z)
18006  common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
18007 
18008  spline = y(1)
18009  xtv1 = xv - x(1)
18010  if (xtv1<0.) then
18011  spline = y(1) + ((y(2)-y(1))/(x(2)-x(1))-s(2)*(x(2)-x(1))/6.)*(xv-x(1))
18012  return
18013  end if
18014  if (xtv1==0.00) then
18015  spline = y(1)
18016  return
18017  end if
18018  if (xtv1>0.) then
18019  xtvn = xv - x(n)
18020  if (xtvn==0.00) then
18021  spline = y(n)
18022  return
18023  end if
18024  if (xtvn>0.) then
18025  spline = y(n) + ((y(n)-y(n-1))/(x(n)-x(n-1))+s(n-1)*(x(n)-x(n-1))/6.)*(xv-x(n))
18026  return
18027  end if
18028  if (xtvn<0.) then
18029  do i = 2, n
18030  xtvi = xv - x(i)
18031  if (xtvi>0.) go to 11
18032  if (xtvi<0.) go to 2
18033  if (xtvi==0.) go to 3
18034 11 continue
18035  end do
18036 3 spline = y(i)
18037  return
18038 2 i = i - 1
18039  dgx = xv - x(i)
18040  ddx = x(i+1) - xv
18041  avx = x(i+1) - x(i)
18042  spline = s(i)*ddx**3/(6.*avx) + s(i+1)*dgx**3/(6.*avx) + (y(i+1)/avx-s(i+1)*avx/6.)*dgx + &
18043  (y(i)/avx-s(i)*avx/6.)*ddx
18044  return
18045  end if
18046  end if
18047  end function spline
18048  ! *******************************************************************
18049  ! SUBROUTINE DERIV2(N)
18050  ! second derivative of spline functions at position (x,y)
18051  ! *******************************************************************
18052  subroutine deriv2(n)
18053  implicit real *8(a-h, o-z)
18054  common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
18055 
18056  avxn = x(n) - x(n-1)
18057  avvxn = x(n-1) - x(n-2)
18058  avyn = y(n) - y(n-1)
18059  avvyn = y(n-1) - y(n-2)
18060  f = avxn - (avvxn**2)/avxn
18061  p(n-1) = 1.
18062  q(n-1) = 0.
18063  if (f/=0.) then
18064  p(n-1) = (-2.*avxn-3.*avvxn-avvxn**2/avxn)/f
18065  q(n-1) = 6.*(avyn/avxn-avvyn/avvxn)/f
18066  end if
18067  nm1 = n - 1
18068  do j = 2, nm1
18069  i = n - j
18070  avx = x(i+1) - x(i)
18071  avvx = x(i+2) - x(i+1)
18072  avy = y(i+1) - y(i)
18073  avvy = y(i+2) - y(i+1)
18074  d = 2.*(avx+avvx) + avvx*p(i+1)
18075  p(i) = -avx/d
18076  q(i) = (6.*(avvy/avvx-avy/avx)-avvx*q(i+1))/d
18077  end do
18078  avx1 = x(2) - x(1)
18079  avvx1 = x(3) - x(2)
18080  g1 = (avvx1/avx1) + 1. - p(2) - (q(2)/q(1))
18081  g2 = (avvx1/(avx1*p(1))) - (avvx1/avx1) - 1. + p(2)
18082  s(1) = (q(1)*g1)/(p(1)*g2)
18083  do i = 1, nm1
18084  s(i+1) = p(i)*s(i) + q(i)
18085  end do
18086  return
18087  end subroutine deriv2
18088  ! *******************************************************************
18089  ! SUBROUTINE DERIF2(N)
18090  ! second derivative of spline functions at position (x,y)
18091  ! *******************************************************************
18092  subroutine derif2(n)
18093  implicit real *8(a-h, o-z)
18094  common /spff/x(400), y(400), s(500), p(500), q(500)
18095 
18096  avxn = x(n) - x(n-1)
18097  avvxn = x(n-1) - x(n-2)
18098  avyn = y(n) - y(n-1)
18099  avvyn = y(n-1) - y(n-2)
18100  f = avxn - (avvxn**2)/avxn
18101  p(n-1) = 1.
18102  q(n-1) = 0.
18103  if (f/=0.) then
18104  p(n-1) = (-2.*avxn-3.*avvxn-avvxn**2/avxn)/f
18105  q(n-1) = 6.*(avyn/avxn-avvyn/avvxn)/f
18106  end if
18107  nm1 = n - 1
18108  do j = 2, nm1
18109  i = n - j
18110  avx = x(i+1) - x(i)
18111  avvx = x(i+2) - x(i+1)
18112  avy = y(i+1) - y(i)
18113  avvy = y(i+2) - y(i+1)
18114  d = 2.*(avx+avvx) + avvx*p(i+1)
18115  p(i) = -avx/d
18116  q(i) = (6.*(avvy/avvx-avy/avx)-avvx*q(i+1))/d
18117  end do
18118  avx1 = x(2) - x(1)
18119  avvx1 = x(3) - x(2)
18120  g1 = (avvx1/avx1) + 1. - p(2) - (q(2)/q(1))
18121  g2 = (avvx1/(avx1*p(1))) - (avvx1/avx1) - 1. + p(2)
18122  s(1) = (q(1)*g1)/(p(1)*g2)
18123  do i = 1, nm1
18124  s(i+1) = p(i)*s(i) + q(i)
18125  end do
18126  return
18127  end subroutine derif2
18128  ! *******************************************************************
18129  ! FUNCTION splinf (N,XV)
18130  ! SPLINE FUNCTION
18131  ! *******************************************************************
18132  function splinf(n, xv)
18133  implicit real *8(a-h, o-z)
18134  common /spff/x(400), y(400), s(500), p(500), q(500)
18135 
18136  splinf = y(1)
18137  xtv1 = xv - x(1)
18138  if (xtv1<0.) then
18139  splinf = y(1) + ((y(2)-y(1))/(x(2)-x(1))-s(2)*(x(2)-x(1))/6.)*(xv-x(1))
18140  return
18141  end if
18142  if (xtv1==0.00) then
18143  splinf = y(1)
18144  return
18145  end if
18146  if (xtv1>0.) then
18147  xtvn = xv - x(n)
18148  if (xtvn==0.00) then
18149  splinf = y(n)
18150  return
18151  end if
18152  if (xtvn>0.) then
18153  splinf = y(n) + ((y(n)-y(n-1))/(x(n)-x(n-1))+s(n-1)*(x(n)-x(n-1))/6.)*(xv-x(n))
18154  return
18155  end if
18156  if (xtvn<0.) then
18157  do i = 2, n
18158  xtvi = xv - x(i)
18159  if (xtvi>0.) go to 11
18160  if (xtvi<0.) go to 2
18161  if (xtvi==0.) go to 3
18162 11 continue
18163  end do
18164 3 splinf = y(i)
18165  return
18166 2 i = i - 1
18167  dgx = xv - x(i)
18168  ddx = x(i+1) - xv
18169  avx = x(i+1) - x(i)
18170  splinf = s(i)*ddx**3/(6.*avx) + s(i+1)*dgx**3/(6.*avx) + (y(i+1)/avx-s(i+1)*avx/6.)*dgx + &
18171  (y(i)/avx-s(i)*avx/6.)*ddx
18172  return
18173  end if
18174  end if
18175  end function splinf
18176  ! *******************************************************************
18177  ! FUNCTION slopf(N,XV)
18178  ! first derivative of the spline function
18179  ! *******************************************************************
18180  function slopf(n, xv)
18181  implicit real *8(a-h, o-z)
18182  common /spff/x(400), y(400), s(500), p(500), q(500)
18183 
18184  do i = 2, n
18185  xtvi = xv - x(i)
18186  if (xtvi>0.) go to 4
18187  if (xtvi<0.) go to 2
18188  if (xtvi==0.00) go to 3
18189 4 continue
18190  end do
18191 3 i = i - 1
18192  avx = x(i+1) - x(i)
18193  slopf = s(i+1)*avx/3. + s(i)*avx/6. + (y(i+1)-y(i))/avx
18194  return
18195 2 i = i - 1
18196  dgx = xv - x(i)
18197  ddx = x(i+1) - xv
18198  avx = x(i+1) - x(i)
18199  slopf = -(s(i)*ddx*ddx)/(2.*avx) + (s(i+1)*dgx*dgx)/(2.*avx) + ((y(i+1)-y(i))/avx) - (avx*(s(i+1)-s(i))/6.)
18200  return
18201  end function slopf
18202  ! *******************************************************************
18203  ! SUBROUTINE area(init)
18204  ! selection of the regions in the space x/a, y/b and z/c. The values
18205  ! a,b and c are the RMS of the bunch in the space x, y, and z
18206  ! The particles lying in any one region are affected with the same
18207  ! color.
18208  ! *******************************************************************
18209  subroutine area(init)
18210  implicit real *8(a-h, o-z)
18211  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
18212  common /faisc/f(10, iptsz), imax, ngood
18213  common /consta/vl, pi, xmat, rpel, qst
18214  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
18215  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
18216  common /tapes/in, ifile, meta
18217  common /zones/frms(6), nzone
18218  dimension inzonn(6)
18219 
18220  if (init==1) then
18221  ! set to -1. the last column of the table f(10,iptsz)
18222  do i = 1, ngood
18223  f(10, i) = -1.
18224  end do
18225  ! read: ityp and nzone; the number of regions
18226  ! ityp=0, the zones are defined in the 3-d space (x/a,y/b,z/c)
18227  ! ityp=1, the zones are defined in the plane (x/a,y/b)
18228  read (in, *) ityp, nzone
18229  write (16, *) 'Number of zones selected:', nzone
18230  if (nzone>5) then
18231  write (16, *) 'Number of zones is greater than 5 ', nzone
18232  stop
18233  end if
18234  ! The regions are selected in the space x/xrms,y/yrms and z/zrms
18235  ! limits of the zones ; read the upper limits of the regions
18236  frms(1) = 0.
18237  if (nzone/=0) then
18238  read (in, *)(frms(i), i=2, nzone)
18239  frms(nzone+1) = 100.
18240  do i = 1, nzone
18241  write (16, *) 'Zone: ', i, ' lower limit: ', frms(i), ' upper limit:', frms(i+1)
18242  end do
18243  else
18244  read (in, *) frms(2)
18245  end if
18246  end if
18247  if (nzone>=2) then
18248  trmoy = 0.
18249  do i = 1, ngood
18250  trmoy = trmoy + f(6, i)
18251  end do
18252  trmoy = trmoy/float(ngood)
18253  xbar = 0.
18254  ybar = 0.
18255  zbar = 0.
18256  imaxx = 0
18257  ! Divide by 100. to convert from centimeters to meters
18258  do np = 1, ngood
18259  gnp = f(7, np)/xmat
18260  vnp = vl*sqrt(1.-1./(gnp*gnp))
18261  zc(np) = (trmoy-f(6,np))*vnp
18262  ! convert from mrad to rad
18263  f3 = f(3, np)*1.e-03
18264  f5 = f(5, np)*1.e-03
18265  ! convert from cm to m
18266  xc(np) = (f(2,np)+zc(np)*f3)/100.
18267  yc(np) = (f(4,np)+zc(np)*f5)/100.
18268  zc(np) = zc(np)/100.
18269  ! evaluate xbar , ybar , zbar
18270  xbar = xbar + xc(np)
18271  ybar = ybar + yc(np)
18272  zbar = zbar + zc(np)
18273  end do
18274  eng = float(ngood)
18275  xbar = xbar/eng
18276  ybar = ybar/eng
18277  zbar = zbar/eng
18278  do np = 1, ngood
18279  xc(np) = xc(np) - xbar
18280  yc(np) = yc(np) - ybar
18281  zc(np) = zc(np) - zbar
18282  end do
18283  ! evaluate the rms sizes
18284  xsqsum = 0.
18285  ysqsum = 0.
18286  zsqsum = 0.
18287  do j = 1, ngood
18288  xcj = xc(j)
18289  ycj = yc(j)
18290  zcj = zc(j)
18291  xsqsum = xsqsum + xcj*xcj
18292  ysqsum = ysqsum + ycj*ycj
18293  zsqsum = zsqsum + zcj*zcj
18294  end do
18295  xrmsz = xsqsum/float(ngood)
18296  yrmsz = ysqsum/float(ngood)
18297  zrmsz = zsqsum/float(ngood)
18298  xrmsz = sqrt(xrmsz)
18299  yrmsz = sqrt(yrmsz)
18300  zrmsz = sqrt(zrmsz)
18301  ! select the particles in the regions and count them
18302  if (ityp==0) then
18303  ! ityp=0, the zones are defined in the 3-d space (x/a,y/b,z/c)
18304  do i = 1, nzone
18305  inzonn(i) = 0
18306  do j = 1, ngood
18307  xcp = xc(j)/xrmsz
18308  ycp = yc(j)/yrmsz
18309  zcp = zc(j)/zrmsz
18310  rxyz = sqrt((xcp*xcp+ycp*ycp+zcp*zcp)/3.)
18311  if (rxyz<frms(i+1) .and. rxyz>=frms(i)) then
18312  inzonn(i) = inzonn(i) + 1
18313  if (init==1) f(10, j) = frms(i+1)
18314  end if
18315  if (f(10,j)==100. .and. init==1) f(10, j) = 0.
18316  end do
18317  if (init==1) then
18318  write (16, *) inzonn(i), ' particles initially in zone ', i
18319  else
18320  write (16, *) inzonn(i), ' particles in zone ', i
18321  end if
18322  end do
18323  else
18324  ! ityp=1, the zones are defined in the plane (x/a,y/b)
18325  do i = 1, nzone
18326  inzonn(i) = 0
18327  do j = 1, ngood
18328  xcp = xc(j)/xrmsz
18329  ycp = yc(j)/yrmsz
18330  zcp = zc(j)/zrmsz
18331  rxyz = sqrt((xcp*xcp+ycp*ycp)/2.)
18332  if (rxyz<frms(i+1) .and. rxyz>=frms(i)) then
18333  inzonn(i) = inzonn(i) + 1
18334  if (init==1) f(10, j) = frms(i+1)
18335  end if
18336  if (f(10,j)==100. .and. init==1) f(10, j) = 0.
18337  end do
18338  if (init==1) then
18339  write (16, *) inzonn(i), ' particles initially in zone ', i
18340  else
18341  write (16, *) inzonn(i), ' particles in zone ', i
18342  end if
18343  end do
18344  end if
18345  end if
18346  return
18347  end subroutine area
18348  ! *******************************************************************
18349  ! subroutine histgrm
18350  ! called by plotting routine grcomp(text,iskale)
18351  ! *******************************************************************
18352  subroutine histgrm
18353  implicit real *8(a-h, o-z)
18354  parameter(iptsz=100002)
18355  common /faisc/f(10, iptsz), imax, ngood
18356  common /consta/vl, pi, xmat, rpel, qst
18357  common /tapes/in, ifile, meta
18358  common /dyn/tref, vref
18359  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
18360  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
18361  common /hist/xpos(200), xn(200), ypos(200), yn(200), zpos(200), zn(200), ixt, iyt, izt
18362  common /hist1/xps(200), xpn(200), yps(200), ypn(200), zps(200), zpn(200), ixpt, iypt, izpt
18363 
18364  trmoy = 0.
18365  wcg = 0.
18366  xcg = 0.
18367  xcg = 0.
18368  ycg = 0.
18369  fnstp = 100.
18370  do i = 1, ngood
18371  trmoy = trmoy + f(6, i)
18372  wcg = wcg + f(7, i)
18373  xcg = xcg + f(2, i)
18374  ycg = ycg + f(4, i)
18375  end do
18376  trmoy = trmoy/float(ngood)
18377  wcg = wcg/float(ngood)
18378  xcg = xcg/float(ngood)
18379  ycg = ycg/float(ngood)
18380  zcg = trmoy*fh
18381  ! Isochronism correction (in case the bunch is not erect)
18382  xb2x = 0.
18383  xb2z = 0.
18384  xbxz = 0.
18385  imaxx = 0
18386  do np = 1, ngood
18387  gnp = f(7, np)/xmat
18388  vnp = vl*sqrt(1.-1./(gnp*gnp))
18389  zc(np) = (trmoy-f(6,np))*vnp/100.
18390  xc(np) = (f(2,np)-xcg)/100.
18391  xb2z = xb2z + zc(np)*zc(np)
18392  xb2x = xb2x + xc(np)*xc(np)
18393  xbxz = xbxz + zc(np)*xc(np)
18394  imaxx = imaxx + 1
18395  end do
18396  xb2z = xb2z/float(imaxx)
18397  xb2x = xb2x/float(imaxx)
18398  xbxz = xbxz/float(imaxx)
18399  apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
18400  ! coordinates of the particles at the point of time position
18401  xbar = 0.
18402  ybar = 0.
18403  zbar = 0.
18404  imaxx = 0
18405  ! Divide by 100. to convert from centimeters to meters
18406  do np = 1, ngood
18407  gnp = f(7, np)/xmat
18408  vnp = vl*sqrt(1.-1./(gnp*gnp))
18409  znp = (trmoy-f(6,np))*vnp
18410  xnp = f(2, np)
18411  zc(np) = znp*cos(apl) + xnp*sin(apl)
18412  xnp = xnp*cos(apl) - znp*sin(apl)
18413  ! convert from mrad to rad
18414  f3 = f(3, np)*1.e-03
18415  f5 = f(5, np)*1.e-03
18416  ! convert from cm to m
18417  xc(np) = (xnp+zc(np)*f3)/100.
18418  yc(np) = (f(4,np)+zc(np)*f5)/100.
18419  zc(np) = zc(np)/100.
18420  ! evaluate xbar , ybar , zbar
18421  xbar = xbar + xc(np)
18422  ybar = ybar + yc(np)
18423  zbar = zbar + zc(np)
18424  end do
18425  eng = float(ngood)
18426  xbar = xbar/eng
18427  ybar = ybar/eng
18428  zbar = zbar/eng
18429  do np = 1, ngood
18430  xc(np) = xc(np) - xbar
18431  yc(np) = yc(np) - ybar
18432  zc(np) = zc(np) - zbar
18433  end do
18434  ! evaluate the rms sizes
18435  xsqsum = 0.
18436  ysqsum = 0.
18437  zsqsum = 0.
18438  do j = 1, ngood
18439  xsqsum = xsqsum + xc(j)*xc(j)
18440  ysqsum = ysqsum + yc(j)*yc(j)
18441  zsqsum = zsqsum + zc(j)*zc(j)
18442  end do
18443  xrmsz = xsqsum/float(ngood)
18444  yrmsz = ysqsum/float(ngood)
18445  zrmsz = zsqsum/float(ngood)
18446  xrmsz = sqrt(xrmsz)
18447  yrmsz = sqrt(yrmsz)
18448  zrmsz = sqrt(zrmsz)
18449  ! normalize the coordinates x, y and z
18450  do j = 1, ngood
18451  xc(j) = xc(j)/xrmsz
18452  yc(j) = yc(j)/yrmsz
18453  zc(j) = zc(j)/zrmsz
18454  end do
18455  ! look for the limits of the cloud of particles in the plane (x/a, y/b, z/c)
18456  ! these limits are assumed included within at most +/- 5 RMS
18457  fract = 5.
18458  xinf = 0.
18459  yinf = 0.
18460  zinf = 0.
18461  ! lower limits
18462  do i = 1, ngood
18463  if ((abs(xc(i))<=fract) .and. (abs(yc(i))<=fract) .and. (abs(zc(i))<=fract)) then
18464  if (xinf>xc(i)) xinf = xc(i)
18465  if (yinf>yc(i)) yinf = yc(i)
18466  if (zinf>zc(i)) zinf = zc(i)
18467  end if
18468  end do
18469  ! upper limits
18470  xsup = xinf
18471  ysup = yinf
18472  zsup = zinf
18473  do i = 1, ngood
18474  if ((abs(xc(i))<=fract) .and. (abs(yc(i))<=fract) .and. (abs(zc(i))<=fract)) then
18475  if (xsup<xc(i)) xsup = xc(i)
18476  if (ysup<yc(i)) ysup = yc(i)
18477  if (zsup<zc(i)) zsup = zc(i)
18478  end if
18479  end do
18480  ! maximal sizes in x, y, and z-directions
18481  pax = (xsup-xinf)
18482  pay = (ysup-yinf)
18483  paz = (zsup-zinf)
18484  ! histogram in x-direction,the step (stepx) is: pax/50
18485  stepx = pax/fnstp
18486  do i = 1, 200
18487  xn(i) = 0.
18488  end do
18489  xtot = 0.
18490  x0 = xinf - stepx
18491  x1 = x0 + stepx
18492  j = 1
18493 150 continue
18494  ! xpos(j): position of the elementary cylinder j
18495  ! xn(j) : number of particles in the elementary cylinder j
18496  ! xtot : total number of particles in x-direction
18497  if (x1>xsup+stepx) go to 160
18498  do i = 1, ngood
18499  if (xc(i)>x0 .and. xc(i)<=x1) xn(j) = xn(j) + 1.
18500  end do
18501  xtot = xtot + xn(j)
18502  xpos(j) = x0 + stepx/2.
18503  j = j + 1
18504  sta = x1
18505  x1 = x1 + stepx
18506  x0 = sta
18507  go to 150
18508 160 continue
18509  ! normalize the number of particles in each step with regard to max.(xn(j))
18510  j = j - 1
18511  ixt = j
18512  xnor = 0.
18513  do i = 1, j
18514  if (xnor<xn(i)) xnor = xn(i)
18515  end do
18516  do i = 1, j
18517  xn(i) = xn(i)/xnor
18518  end do
18519  ! histogram in y-direction,the step (stepy) is: pay/50
18520  stepy = pay/fnstp
18521  do i = 1, 200
18522  yn(i) = 0.
18523  end do
18524  ytot = 0.
18525  y0 = yinf - stepy
18526  y1 = y0 + stepy
18527  j = 1
18528  ! ypos(j): position of the step j
18529  ! yn(j) : number of particles lying in the j
18530  ! ytot : total number of particles in y-direction
18531 151 continue
18532  if (y1>ysup+stepy) go to 161
18533  do i = 1, ngood
18534  if (yc(i)>y0 .and. yc(i)<=y1) yn(j) = yn(j) + 1.
18535  end do
18536  ytot = ytot + yn(j)
18537  ypos(j) = y0 + stepy/2.
18538  j = j + 1
18539  sta = y1
18540  y1 = y1 + stepy
18541  y0 = sta
18542  go to 151
18543 161 continue
18544  j = j - 1
18545  iyt = j
18546  y0 = yinf
18547  ! normalize the number of particles in step with regard to max(yn(j))
18548  ynor = 0.
18549  do i = 1, j
18550  if (ynor<yn(i)) ynor = yn(i)
18551  end do
18552  do i = 1, j
18553  yn(i) = yn(i)/ynor
18554  end do
18555  ! histogram in z-direction,the step (stepz) is: paz/50
18556  do i = 1, 200
18557  zn(i) = 0.
18558  end do
18559  stepz = paz/fnstp
18560  ztot = 0.
18561  z0 = zinf - stepz
18562  z1 = z0 + stepz
18563  j = 1
18564  ! of length :stepz and radius:ray
18565  ! zpos(j): position of the step j
18566  ! zn(j) : number of particles in the step j
18567  ! ztot : total number of particles in z-direction
18568 152 continue
18569  if (z1>zsup+2.*stepz) go to 162
18570  do i = 1, ngood
18571  if (zc(i)>z0 .and. zc(i)<=z1) zn(j) = zn(j) + 1.
18572  end do
18573  ztot = ztot + zn(j)
18574  zpos(j) = z0 + stepz/2.
18575  j = j + 1
18576  sta = z1
18577  z1 = z1 + stepz
18578  z0 = sta
18579  go to 152
18580 162 continue
18581  j = j - 1
18582  izt = j
18583  ! *et*2011 added next line
18584  z0 = zinf
18585  ! normalize the number of particles in each step with regard to max(zn(j))
18586  znor = 0.
18587  do i = 1, j
18588  if (znor<zn(i)) znor = zn(i)
18589  end do
18590  do i = 1, j
18591  zn(i) = zn(i)/znor
18592  end do
18593  ! look for the limits of xp, yp, zp
18594  xpinf = f(3, 1)
18595  ypinf = f(5, 1)
18596  zpinf = f(6, 1) - trmoy
18597  ! lower limits
18598  do i = 1, ngood
18599  f3 = f(3, i)
18600  f5 = f(5, i)
18601  f6 = f(6, i) - trmoy
18602  if (xpinf>f3) xpinf = f3
18603  if (ypinf>f5) ypinf = f5
18604  if (zpinf>f6) zpinf = f6
18605  end do
18606  ! upper limits
18607  xpsup = xpinf
18608  ypsup = ypinf
18609  zpsup = zpinf
18610  do i = 1, ngood
18611  f3 = f(3, i)
18612  f5 = f(5, i)
18613  f6 = f(6, i) - trmoy
18614  if (xpsup<f3) xpsup = f3
18615  if (ypsup<f5) ypsup = f5
18616  if (zpsup<f6) zpsup = f6
18617  end do
18618  ! maximal sizes in xp, yp, and zp-directions
18619  paxp = (xpsup-xpinf)
18620  payp = (ypsup-ypinf)
18621  pazp = (zpsup-zpinf)
18622  ! evaluate the rms sizes in xp, yp, zp
18623  xpsum = 0.
18624  ypsum = 0.
18625  zpsum = 0.
18626  do i = 1, ngood
18627  f3 = f(3, i)
18628  f5 = f(5, i)
18629  f6 = f(6, i) - trmoy
18630  xpsum = xpsum + f3*f3
18631  ypsum = ypsum + f5*f5
18632  zpsum = zpsum + f6*f6
18633  end do
18634  xpsum = xpsum/float(ngood)
18635  ypsum = ypsum/float(ngood)
18636  zpsum = zpsum/float(ngood)
18637  xpsum = sqrt(xpsum)
18638  ypsum = sqrt(ypsum)
18639  zpsum = sqrt(zpsum)
18640  ! histogram in xp-direction,the step (stxp) is: paxp/50
18641  stpx = paxp/fnstp
18642  do i = 1, 200
18643  xpn(i) = 0.
18644  end do
18645  xp0 = xpinf - stpx
18646  xp1 = xp0 + stpx
18647  j = 1
18648 250 continue
18649  ! xps(j): position of the step j
18650  ! xpn(j): number of particles lying in the step j
18651  if (xp1>xpsup+stpx) go to 260
18652  do i = 1, ngood
18653  if (f(3,i)>xp0 .and. f(3,i)<=xp1) xpn(j) = xpn(j) + 1.
18654  end do
18655  xps(j) = xp0 + stpx/2.
18656  j = j + 1
18657  sta = xp1
18658  xp1 = xp1 + stpx
18659  xp0 = sta
18660  go to 250
18661 260 continue
18662  ! normalize the number of particles in each step with regard to max.(xpn(j))
18663  j = j - 1
18664  ixpt = j
18665  xnor = 0.
18666  do i = 1, j
18667  if (xnor<xpn(i)) xnor = xpn(i)
18668  end do
18669  do i = 1, j
18670  xpn(i) = xpn(i)/xnor
18671  xps(i) = xps(i)/xpsum
18672  end do
18673  ! histogram in yp-direction,the step (stpy) is: payp/50
18674  stpy = payp/fnstp
18675  do i = 1, 200
18676  ypn(i) = 0.
18677  end do
18678  yp0 = ypinf - stpy
18679  yp1 = yp0 + stpy
18680  j = 1
18681  ! yps(j): position of the step j in mrd
18682  ! ypn(j) : number of particles lying in the j
18683 251 continue
18684  if (yp1>ypsup+stpy) go to 261
18685  do i = 1, ngood
18686  if (f(5,i)>yp0 .and. f(5,i)<=yp1) ypn(j) = ypn(j) + 1.
18687  end do
18688  yps(j) = yp0 + stpy/2.
18689  j = j + 1
18690  sta = yp1
18691  yp1 = yp1 + stpy
18692  yp0 = sta
18693  go to 251
18694 261 continue
18695  j = j - 1
18696  iypt = j
18697  yp0 = ypinf
18698  ! normalize the number of particles in step with regard to max(ypn(j))
18699  ynor = 0.
18700  do i = 1, j
18701  if (ynor<ypn(i)) ynor = ypn(i)
18702  end do
18703  do i = 1, j
18704  ypn(i) = ypn(i)/ynor
18705  yps(i) = yps(i)/ypsum
18706  end do
18707  ! histogram in zp-direction,the step (stpz) is: pazp/50
18708  do i = 1, 200
18709  zpn(i) = 0.
18710  end do
18711  stpz = pazp/fnstp
18712  zp0 = zpinf - stpz
18713  zp1 = zp0 + stpz
18714  j = 1
18715  ! of length :stepz and radius:ray
18716  ! zps(j): position of the step j (deg)
18717  ! zpn(j) : number of particles in the step j
18718 252 continue
18719  if (zp1>zpsup+2.*stpz) go to 262
18720  do i = 1, ngood
18721  f6 = f(6, i) - trmoy
18722  if (f6>zp0 .and. f6<=zp1) zpn(j) = zpn(j) + 1.
18723  end do
18724  zps(j) = zp0 + stpz/2.
18725  j = j + 1
18726  sta = zp1
18727  zp1 = zp1 + stpz
18728  zp0 = sta
18729  go to 252
18730 262 continue
18731  ! normalize the number of particles in each step with regard to max(zn(j))
18732  j = j - 1
18733  izpt = j
18734  zpnor = 0.
18735  do i = 1, j
18736  if (zpnor<zpn(i)) zpnor = zpn(i)
18737  end do
18738  do i = 1, j
18739  zpn(i) = zpn(i)/zpnor
18740  zps(i) = zps(i)/zpsum
18741  end do
18742  return
18743  end subroutine histgrm
18744  ! *******************************************************************
18745  ! SUBROUTINE daves
18746  ! Write the characteristics of the beam to the disk
18747 
18748  ! ---- statistics (dE-dPHI)
18749  ! dav1(i,10) : extension of phase dPHI (deg)
18750  ! dav1(i,11) : dispersion of energy dE (MeV)
18751  ! dav1(i,12) : emittance (MeV*rad)
18752  ! dav1(i,23) : correlation between dE an dPHI
18753 
18754  ! ---- statistics (x-xp)
18755 
18756  ! dav1(i,13): x-extension (mm)
18757  ! dav1(i,14): xp-extension (mrad)
18758  ! dav1(i,15): correlation between x and xp
18759  ! dav1(i,16): Emittance(norm) x-xp (mm*mrad)
18760  ! dav1(i,17): Emittance(non norm) x-xp (mm*mrad)
18761 
18762  ! ---- statistics (y-yp)
18763  ! dav1(i,18): y-extension (mm)
18764  ! dav1(i,19): yp-extension (mrad)
18765  ! dav1(i,20): correlation between y and yp
18766  ! dav1(i,21) : Emittance(norm) y-yp (mm*mrad)
18767  ! dav1(i,22) : Emittance(non norm) y-yp (mm*mrad)
18768 
18769  ! with CHASE These parameters are in the array dav2 like above
18770  ! *******************************************************************
18771  subroutine daves
18772  implicit real *8(a-h, o-z)
18773  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
18774  common /consta/vl, pi, xmat, rpel, qst
18775  common /faisc/f(10, iptsz), imax, ngood
18776  common /speda/dave, idave
18777  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
18778  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
18779  common /etcom/cog(8), exten(17), fd(iptsz)
18780  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
18781  common /cptemit/xltot(maxcell1), nbemit
18782  common /poro/irot1, irot2
18783  logical irot1, irot2
18784  common /secdr/iseor
18785  common /itvole/itvol, imamin
18786  common /dyni/vrefi, trefi, fhinit, acpt
18787  common /qfkd/ityq
18788  common /shortl/davprt
18789  logical iseor
18790  logical dave, chasit, ichaes, itvol, imamin, ityq
18791  character *80 davprt(maxcell1)
18792  ! dave end
18793  write (12, 3334)
18794 3334 format ('*****************************************************')
18795  ! 34 FORMAT(10A8)
18796  ! ********************************************************************
18797  write (12, *) ' Energies are in [MeV], phases in [deg]', ' lengths in [mm] ,tof in [deg]'
18798  write (12, *) ' ** For lenses followed by :', ' Cummulative length, element type, length '
18799 
18800  write (12, *) ' ** For emit followed by'
18801  write (12, *) ' * Line 1:', ' Particle reference: beta, energy, tof ', &
18802  ' COG: energy, tof, energy offset, tof offset'
18803  write (12, *) ' * Line 2:', ' COG coordinates for x xp y yp (mm and mrad)'
18804  write (12, *) ' * Line 3:', ' alpha-x beta-x(mm/mrad) alpha-y beta-y(mm/mrad)', ' alpha-z beta-z(ns/keV)'
18805  write (12, *) ' * Line 4:', ' alpha-z beta-z(deg/keV) emit-z(non norm.,keV.deg) f(MHz)'
18806  write (12, *) ' * Line 5:', ' dPHI(deg) dW(keV) r12 long. emittance', ' (keV.ns) particles left'
18807  write (12, *) ' * Line 6:', ' x(mm) xp(mrad) r12 hor. emittance', ' (norm & non norm, mm.mrad)'
18808  write (12, *) ' * Line 7:', ' y(mm) yp(mrad) r12 vert. emittance', ' (norm & non norm, mm.mrad)'
18809  ! ********************************************************************
18810  write (12, 3334)
18811  write (12, *) ' Simulation with ', imax, ' particles'
18812  if (iseor) then
18813  write (12, *) ' Second order transport matrix '
18814  else
18815  write (12, *) ' First order transport matrix '
18816  end if
18817  if (ichaes) then
18818  write (12, *) ' Beam intensity ', beamc, ' mA'
18819  if (iscsp==1) write (12, *) ' Space charge calculations with HERSC '
18820  if (iscsp==2) write (12, *) ' Space charge calculations with SCHERM '
18821  if (iscsp==3 .or. iscsp==4) write (12, *) ' Space charge calculations with SCHEFF '
18822  if (sce10==1) write (12, *) &
18823  'Space charge calculated for all relevant elements, but not at drifts'
18824  if (sce10==2) write (12, *) 'Space charge calculated for accelerating elements only'
18825  if (sce10==3) write (12, *) 'Space charge calculated for all relevant elements'
18826  end if
18827  if (itvol) write (12, *) ' TOF is operational in accelerating elements '
18828  if (imamin) write (12, *) 'Phase adjustments for accelerating elements active'
18829  write (12, 3334)
18830  ifirst = 1
18831  iit6 = 0
18832  nemit = 0
18833  do i = 1, idav
18834  if (davprt(i)/='') write (12, '(A)') davprt(i)
18835  if (iitem(i)==1) then
18836  ! cavity
18837  n = int(dav1(i,25)+.5)
18838  if (itvol .and. imamin) then
18839  write (12, 1000) dav1(i, 24), n, dav1(i, 1), dav1(i, 38), dav1(i, 39)
18840 1000 format (f9.2, ' mm Cavity ', i3, ' length ', f7.2, ' mm', /, ' phase offset: before adjustement ', e12.5, &
18841  ' deg', ' after adjustement ', e14.7, ' deg')
18842  else
18843  write (12, 2789) dav1(i, 24), n, dav1(i, 1), dav1(i, 38)
18844  end if
18845 2789 format (f9.2, ' mm Cavity ', i3, ' length ', f7.2, ' mm', ' phase offset: ', e12.5, ' deg')
18846  end if
18847 
18848  if (iitem(i)==2) then
18849  ! quadrupole (magnetic)
18850  write (12, 1010) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), &
18851  dav1(i, 36)
18852 1010 format (f9.2, ' mm Quadrupole: length = ', e12.5, ' mm', ' aperture radius = ', e12.5, ' mm', /, &
18853  ' field = ', e12.5, ' kG K2 = ', e12.5, ' cm-2 gradient = ', e12.5, ' kG/cm', /, ' momentum = ', e12.5, &
18854  ' kG.cm particles left ', f7.0)
18855  write (12, *)
18856  end if
18857 
18858  if (iitem(i)==3) then
18859  ! emiprt
18860  write (12, 305)
18861 305 format ('********** beam (emit card) ', '**********')
18862  nemit = nemit + 1
18863  ! omment write(13,556) nemit,xltot(nemit)/100.,dav1(i,12)*1000.,
18864  ! omment * dav1(i,6),dav1(i,30)
18865  ! omment write(14,557) nemit,xltot(nemit)/100.,dav1(i,16),dav1(i,21)
18866  ! omment556 format(2x,i3,3(3x,f8.3),3x,f6.0)
18867  ! omment557 format(2x,i3,3(3x,f8.3))
18868  ! ****************************************
18869  write (12, 1001)(dav1(i,j), j=3, 9)
18870 1001 format (2x, f7.5, 4(1x,e14.7), 2(2x,e12.5), ' MeV-deg')
18871  write (12, 2003)(dav1(i,j), j=31, 34)
18872 2003 format (4(2x,f7.3), ' mm and mrad ')
18873  ! --- following lines describe Courant-Snyder parameters
18874  fh = dav1(i, 40)
18875  ! 1) alpz betz
18876 
18877  ! 1-a) emz: emittance (keV*deg) betz(deg/keV) gamz(keV/deg)
18878  emz = dav1(i, 12)*1000.*(180./pi)
18879  betz = 0.
18880  if (emz>1.e-10) betz = dav1(i, 10)*dav1(i, 10)/emz
18881  dez = dav1(i, 11)*1000.
18882  gamz = 0.
18883  if (emz>1.e-10) gamz = dez*dez/emz
18884  alpz = 0.
18885  if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
18886  if (dav1(i,23)>0.) alpz = -alpz
18887 
18888  ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
18889  emzz = 1.e12*dav1(i, 12)/fh
18890  dphizz = 1.e09*dav1(i, 10)/fh*(pi/180.)
18891  betzz = 0.
18892  if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
18893  gamzz = 0.
18894  if (emzz>1.e-10) gamzz = dez*dez/emzz
18895  alpzz = 0.
18896  if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
18897  if (dav1(i,23)>0.) alpzz = -alpzz
18898 
18899  ! 2) alpx btx
18900  ! betx(mm/mrad) gamx (mrad/mm)
18901  betx = 0.
18902  emx = dav1(i, 17)
18903  if (emx>1e-10) betx = dav1(i, 13)*dav1(i, 13)/emx
18904  gamx = 0.
18905  if (emx>1e-10) gamx = dav1(i, 14)*dav1(i, 14)/emx
18906  alpx = 0.
18907  if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
18908  if (dav1(i,15)>0.) alpx = -alpx
18909 
18910  ! 3) alpy bety
18911  ! bety(mm/mrad) gamy (mrad/mm)
18912  bety = 0.
18913  emy = dav1(i, 22)
18914  if (emy>1e-10) bety = dav1(i, 18)*dav1(i, 18)/emy
18915  gamy = 0.
18916  if (emy>1e-10) gamy = dav1(i, 19)*dav1(i, 19)/emy
18917  alpy = 0.
18918  if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
18919  if (dav1(i,20)>0.) alpy = -alpy
18920 
18921  ! betzz: ns/keV
18922  write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
18923 3213 format (3(2x,e12.5,2x,e12.5), 2x, e12.5)
18924  ! emittance (keV*deg) betz(deg/keV)
18925  write (12, 597) alpz, betz, emz, fh/(2.*pi*1.e6)
18926 597 format (2x, f8.4, 2x, e13.6, 2x, e13.6, ' keV.deg', 2x, f8.3, ' MHz')
18927  if (emzz>1000.) then
18928  ! ns.MeV
18929  write (12, 6332) dav1(i, 10), dez, dav1(i, 23), emzz/1000., dav1(i, 30)
18930 6332 format (2x, f7.3, 1x, f10.2, 2x, f8.4, 3x, f8.3, ' ns.MeV ', f7.0, ' particles left')
18931  else
18932  ! ns.keV
18933  write (12, 1002) dav1(i, 10), dez, dav1(i, 23), emzz, dav1(i, 30)
18934 1002 format (2x, e12.5, 2x, f7.2, 2x, f8.4, 2x, f7.3, ' ns.keV ', f7.0, ' particles left')
18935  end if
18936  write (12, 1003)(dav1(i,j), j=13, 22)
18937 1003 format (2(2x,f7.3,3x,f8.3,2x,f8.4,2x,e12.5,' mm.mrad (norm)',2x,f7.3,' (non norm)',/))
18938  write (12, *)
18939  if (dav1(i,26)==1.) then
18940  write (12, 8333)(dav2(i,j), j=31, 33)
18941 8333 format ('********** With chase', 3(1x,f6.4), ' **********')
18942  write (12, 1001)(dav1(i,j), j=3, 9)
18943  write (12, 2003)(dav2(i,j), j=26, 29)
18944  ! following lines describe Courant-Snyder parameters
18945  ! 1) alpz betz
18946 
18947  ! 1-a) emz: emittance (keV*deg) betz(deg/keV) gamz(keV/deg)
18948  emz = dav2(i, 12)*1000.*(180./pi)
18949  betz = 0.
18950  if (emz>1.e-10) betz = dav2(i, 10)*dav2(i, 10)/emz
18951  dez = dav2(i, 11)*1000.
18952  gamz = 0.
18953  if (emz>1.e-10) gamz = dez*dez/emz
18954  alpz = 0.
18955  if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
18956  if (dav2(i,23)>0.) alpz = -alpz
18957 
18958  ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
18959  emzz = 1.e12*dav2(i, 12)/fh
18960  dphizz = 1.e09*dav2(i, 10)/fh*(pi/180.)
18961  betzz = 0.
18962  if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
18963  gamzz = 0.
18964  if (emzz>1.e-10) gamzz = dez*dez/emzz
18965  alpzz = 0.
18966  if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
18967  if (dav2(i,23)>0.) alpzz = -alpzz
18968 
18969  ! 2) alpx btx
18970  ! betx(mm/mrad) gamx (mrad/mm)
18971  betx = 0.
18972  emx = dav1(i, 17)
18973  if (emx>1e-10) betx = dav2(i, 13)*dav2(i, 13)/emx
18974  gamx = 0.
18975  if (emx>1e-10) gamx = dav2(i, 14)*dav2(i, 14)/emx
18976  alpx = 0.
18977  if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
18978  if (dav2(i,15)>0.) alpx = -alpx
18979 
18980  ! 3) alpy bety
18981  ! bety(mm/mrad) gamy (mrad/mm)
18982  bety = 0.
18983  emy = dav2(i, 22)
18984  if (emy>1e-10) bety = dav2(i, 18)*dav2(i, 18)/emy
18985  gamy = 0.
18986  if (emy>1e-10) gamy = dav2(i, 19)*dav2(i, 19)/emy
18987  alpy = 0.
18988  if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
18989  if (dav2(i,20)>0.) alpy = -alpy
18990 
18991  ! betzz: ns/keV
18992  write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
18993  if (emzz>1000.) then
18994  ! ns.MeV
18995  write (12, 6332) dav2(i, 10), dez, dav2(i, 23), emzz/1000., dav2(i, 30)
18996  else
18997  ! ns.keV
18998  write (12, 1002) dav2(i, 10), dez, dav2(i, 23), emzz, dav2(i, 30)
18999  end if
19000  ifirst = 0
19001  ! omment write(15,1556) nemit,xltot(nemit)/100.,dav2(i,12)*1000.
19002  ! omment1556 format(2x,i3,2(3x,f8.3))
19003  ! omment write(18,1557) nemit,xltot(nemit)/100.,dav2(i,16),dav2(i,21)
19004  ! omment1557 format(2x,i3,3(3x,f8.3))
19005  ! omment656 format(2x,i3,3x,f7.3)
19006  write (12, 1003)(dav2(i,j), j=13, 22)
19007  write (12, *)
19008  end if
19009  end if
19010  if (iitem(i)==4) then
19011  ! bending magnet
19012  write (12, 1025) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3)
19013 1025 format (f9.2, ' mm bending magnet: central trajectory: ', f8.2, ' mm', /, ' bend angle: ', f7.3, &
19014  ' deg bending radius: ', e12.5, ' mm')
19015  write (12, 1029) dav1(i, 16), dav1(i, 14), dav1(i, 15)
19016 1029 format (' field: ', f7.3, ' T n: ', f8.3, ' beta: ', f8.3)
19017  write (12, 1026) dav1(i, 6), dav1(i, 9), dav1(i, 7), dav1(i, 8), dav1(i, 5)
19018 1026 format (' *Entrance ', /, ' pole-face rotation:', f8.3, ' deg curvature: ', f8.3, ' mm', /, &
19019  ' fringe field corrections: K1 ', f8.3, ' K2 ', f8.3, /, ' vertical half-aperture: ', f8.3, ' mm')
19020  write (12, 1027) dav1(i, 10), dav1(i, 13), dav1(i, 11), dav1(i, 12), dav1(i, 17)
19021 1027 format (' *Exit ', /, ' pole-face rotation :', f8.3, ' deg curvature: ', f8.3, ' mm', /, &
19022  ' fringe field correction: K1 ', f7.3, ' K2 ', f7.3, /, ' vertical half-aperture: ', f8.3, ' mm')
19023  write (12, 1028) dav1(i, 37)
19024 1028 format (' particles left ', f7.0)
19025  write (12, *)
19026  end if
19027  if (iitem(i)==5) then
19028  ! solenoid
19029  write (12, 5010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 36)
19030 5010 format (f9.2, ' mm Solenoid: length = ', f8.3, ' mm', ' field = ', e12.5, ' kG K = ', e12.5, ' cm-1', /, &
19031  ' momentum = ', e12.5, ' kG.cm particles left ', f7.0)
19032  write (12, *)
19033  end if
19034  if (iitem(i)==6) then
19035  ! From adjust or from entre(not yet introduced) input beam reference
19036  write (12, 303)
19037 303 format ('********** INITIAL BEAM **********')
19038  write (12, 2003)(dav1(i,j), j=31, 34)
19039  ! 1) alpz betz
19040 
19041  ! 1-a) emz: emittance (keV*deg) betz(deg/keV) gamz(keV/deg)
19042  emz = dav1(i, 12)*1000.*(180./pi)
19043  betz = 0.
19044  if (emz>1.e-10) betz = dav1(i, 10)*dav1(i, 10)/emz
19045  dez = dav1(i, 11)*1000.
19046  gamz = 0.
19047  if (emz>1.e-10) gamz = dez*dez/emz
19048  alpz = 0.
19049  if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
19050 
19051  ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
19052  emzz = 1.e12*dav1(i, 12)/fhinit
19053  dphizz = 1.e09*dav1(i, 10)/fhinit*(pi/180.)
19054  betzz = 0.
19055  if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
19056  gamzz = 0.
19057  if (emzz>1.e-10) gamzz = dez*dez/emzz
19058  alpzz = 0.
19059  if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
19060 
19061  ! 2) alpx btx
19062  ! betx(mm/mrad) gamx (mrad/mm)
19063  betx = 0.
19064  emx = dav1(i, 17)
19065  if (emx>1e-10) betx = dav1(i, 13)*dav1(i, 13)/emx
19066  gamx = 0.
19067  if (emx>1e-10) gamx = dav1(i, 14)*dav1(i, 14)/emx
19068  alpx = 0.
19069  if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
19070 
19071  ! 3) alpy bety
19072  ! bety(mm/mrad) gamy (mrad/mm)
19073  bety = 0.
19074  emy = dav1(i, 22)
19075  if (emy>1e-10) bety = dav1(i, 18)*dav1(i, 18)/emy
19076  gamy = 0.
19077  if (emy>1e-10) gamy = dav1(i, 19)*dav1(i, 19)/emy
19078  alpy = 0.
19079  if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
19080 
19081  ! betzz: ns/keV
19082  write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
19083  fh = dav1(i, 40)
19084  ! emittance (keV*deg) betz(deg/keV)
19085  write (12, 597) alpz, betz, emz, fh/(2.*pi*1.e6)
19086  if (emzz>1000.) then
19087  ! ns.MeV
19088  write (12, 6332) dav1(i, 10), dez, dav1(i, 23), emzz/1000., dav1(i, 30)
19089  else
19090  ! ns.keV
19091  write (12, 1002) dav1(i, 10), dez, dav1(i, 23), emzz, dav1(i, 30)
19092  end if
19093  write (12, 1003)(dav1(i,j), j=13, 22)
19094  iit6 = 1
19095  write (12, 304)
19096 304 format ('********** With chase ', '**********')
19097  write (12, 2003)(dav2(i,j), j=26, 29)
19098  ! 1) alpz betz
19099 
19100  ! 1-a) emz: emittance (keV*deg) betz(deg/keV) gamz(keV/deg)
19101  emz = dav2(i, 12)*1000.*(180./pi)
19102  betz = 0.
19103  if (emz>1.e-10) betz = dav2(i, 10)*dav2(i, 10)/emz
19104  dez = dav2(i, 11)*1000.
19105  gamz = 0.
19106  if (emz>1.e-10) gamz = dez*dez/emz
19107  alpz = 0.
19108  if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
19109 
19110  ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
19111  emzz = 1.e12*dav2(i, 12)/fh
19112  dphizz = 1.e09*dav2(i, 10)/fh*(pi/180.)
19113  betzz = 0.
19114  if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
19115  gamzz = 0.
19116  if (emzz>1.e-10) gamzz = dez*dez/emzz
19117  alpzz = 0.
19118  if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
19119 
19120  ! 2) alpx btx
19121  ! betx(mm/mrad) gamx (mrad/mm)
19122  betx = 0.
19123  emx = dav1(i, 17)
19124  if (emx>1e-10) betx = dav2(i, 13)*dav2(i, 13)/emx
19125  gamx = 0.
19126  if (emx>1e-10) gamx = dav2(i, 14)*dav2(i, 14)/emx
19127  alpx = 0.
19128  if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
19129 
19130  ! 3) alpy bety
19131 
19132  ! bety(mm/mrad) gamy (mrad/mm)
19133  bety = 0.
19134  emy = dav2(i, 22)
19135  if (emy>1e-10) bety = dav2(i, 18)*dav2(i, 18)/emy
19136  gamy = 0.
19137  if (emy>1e-10) gamy = dav2(i, 19)*dav2(i, 19)/emy
19138  alpy = 0.
19139  if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
19140 
19141  ! betzz: ns/keV
19142  write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
19143  if (emzz>1000.) then
19144  ! ns.MeV
19145  write (12, 6332) dav2(i, 10), dez, dav2(i, 23), emzz/1000., dav2(i, 30)
19146  else
19147  ! ns.keV
19148  write (12, 1002) dav2(i, 10), dez, dav2(i, 23), emzz, dav2(i, 30)
19149  end if
19150  ifirst = 0
19151  write (12, 1003)(dav2(i,j), j=13, 22)
19152  write (12, *)
19153  end if
19154  if (iitem(i)==7) then
19155  ! drift
19156  write (12, 7010) dav1(i, 4), dav1(i, 1), dav1(i, 36)
19157 7010 format (f9.2, ' mm Drift: length ', f10.3, ' mm ', /, ' particles left ', f7.0)
19158  write (12, *)
19159  end if
19160  if (iitem(i)==8) then
19161  ! buncher
19162  if (.not. imamin) write (12, 8010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 36)
19163 8010 format (f9.2, ' mm Buncher ', f9.3, ' MV ', ' RF Phase ', f9.3, ' deg Aperture radius', f5.1, ' cm', /, &
19164  ' particles left ', f7.0)
19165  if (imamin) write (12, 8110) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 5), dav1(i, 3), dav1(i, 36)
19166 8110 format (f9.2, ' mm Buncher ', f9.3, ' MV ', ' RF Phase ', f9.3, ' deg correction ', f9.3, ' deg', &
19167  ' Aperture radius', f5.1, ' cm', /, ' particles left ', f7.0)
19168  write (12, *)
19169  end if
19170  if (iitem(i)==9) then
19171  ! steerer
19172  if (dav1(i,2)==0.) then
19173  write (12, 8020) dav1(i, 3), dav1(i, 1)
19174 8020 format (f9.2, ' mm Hor. Mag. Steerer ', e12.5, ' Tm ')
19175  else if (dav1(i,2)==1.) then
19176  write (12, 8021) dav1(i, 3), dav1(i, 1)
19177 8021 format (f9.2, ' mm Ver. Mag. Steerer ', f12.5, ' Tm ')
19178  else if (dav1(i,2)==2.) then
19179  write (12, 8022) dav1(i, 3), dav1(i, 1)
19180 8022 format (f9.2, ' mm Hor. El. Steerer ', e12.5, ' kVm/m ')
19181  else if (dav1(i,2)==3.) then
19182  write (12, 8023) dav1(i, 3), dav1(i, 1)
19183 8023 format (f9.2, ' mm Ver. El. Steerer ', e12.5, ' kVm/m ')
19184  end if
19185  write (12, *)
19186  end if
19187  if (iitem(i)==10) then
19188  ! sextupole
19189  write (12, 1011) dav1(i, 4), dav1(i, 1), dav1(i, 6), dav1(i, 3), dav1(i, 5), dav1(i, 2), dav1(i, 7), &
19190  dav1(i, 36)
19191 1011 format (f9.2, ' mm Sextupole: length = ', f7.3, ' mm', ' aperture radius = ', e12.5, ' cm', /, &
19192  ' field = ', e12.5, ' kG KS2 = ', e12.5, ' cm-3', ' gradient = ', e12.5, ' kG/cm2', /, &
19193  ' momentum = ', e12.5, ' kG.cm particles left ', f7.0)
19194  write (12, *)
19195  end if
19196  if (iitem(i)==11) then
19197  ! solenoid+quadrupole
19198  write (12, 5011) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 3), dav1(i, 5), &
19199  dav1(i, 8), dav1(i, 36)
19200 5011 format (f9.2, ' mm Sol+Quad: length = ', f7.3, ' mm aperture radius= ', e12.5, ' mm', /, &
19201  ' Solenoid: field = ', e12.5, ' kG K = ', e12.5, ' cm-1', /, ' Quadrupole: field ', e12.5, ' kG K2 = ', &
19202  e12.5, ' cm-2', /, ' momentum = ', e12.5, ' kG.cm particles left ', f7.0)
19203  write (12, *)
19204  end if
19205  if (iitem(i)==12) then
19206  ! quadrupole + sextupole
19207  write (12, 5021) dav1(i, 4), dav1(i, 1), dav1(i, 6), dav1(i, 2), dav1(i, 3), dav1(i, 7), dav1(i, 8), &
19208  dav1(i, 10), dav1(i, 36)
19209 5021 format (f9.2, ' mm Quad+Sext: length = ', e12.5, ' mm ', ' aperture radius = ', e12.5, ' mm', /, &
19210  ' Quadrupole: B = ', e12.5, ' kG K2 = ', e12.5, ' cm-2', /, ' Sextupole: B = ', e12.5, ' kG K2 = ', &
19211  e12.5, ' cm-3', /, ' momentum = ', e12.5, ' kG.cm particles left ', f7.0)
19212  write (12, *)
19213  end if
19214  if (iitem(i)==13) then
19215  ! electron gun
19216  write (12, 5031) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 6), dav1(i, 36)
19217 5031 format (f9.2, ' mm DC egun length:', f7.3, ' mm', /, ' Crest field:', f8.3, ' MV/m', 3x, ' field stength:', &
19218  f8.3, ' kV', /, ' beta ( output):', e12.5, ' particles left ', f7.0)
19219  ! 14/01/2010 write(12,5032) dav1(i,5),dav1(i,7)
19220  ! 14/10/2010 5032 format(' beam (emit card) at ',e12.5,
19221  ! 14/10/2010 * ' mm from the cathode, field (MV/m) ',e12.5)
19222  write (12, *)
19223  end if
19224  ! rfqcl (RFQ cell)
19225  if (iitem(i)==14) then
19226  ncell = int(dav1(i,7))
19227  write (12, 5041) dav1(i, 4), ncell, dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 36)
19228 5041 format (f9.2, ' mm rfq cell:', i5, ' length: ', f7.3, ' mm', /, ' V/r02: ', e12.5, ' kV/mm**2 AV:', e12.5, &
19229  ' kV ', ' type: ', f3.0, /, ' energy(output): ', e12.5, ' MeV ', ' particles left ', f7.0)
19230  write (12, *)
19231  end if
19232  ! rfqptq (RFQ)
19233  if (iitem(i)==15) then
19234  ncell = int(dav1(i,7))
19235  write (12, 5042) dav1(i, 4), ncell, dav1(i, 5), dav1(i, 9), dav1(i, 8), dav1(i, 6), dav1(i, 36)
19236 5042 format (f9.2, ' mm rfq: number of cells:', i5, ' total length: ', e12.5, ' mm', /, &
19237  ' intervane voltage (reference): ', e12.5, ' kV', /, ' intervane voltage (bunch): ', e12.5, ' kV', /, &
19238  ' energy (output): ', e12.5, ' MeV', /, ' particles left ', f7.0)
19239  write (12, *)
19240  end if
19241  ! stipper foils
19242  if (iitem(i)==16) then
19243  write (12, 5043) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 36)
19244 5043 format (f9.2, ' mm stripper: atomic number: ', f4.0, ' atomic mass : ', f4.0, ' thickness :', e12.5, &
19245  ' g/cm**2', /, 4x, 'particles charge : ', f4.0, 2x, 'energy loss: ', e12.5, ' MeV', /, &
19246  ' particles left ', f7.0)
19247  write (12, *)
19248  end if
19249  ! accelerating gap
19250  if (iitem(i)==17) then
19251  n = int(dav1(i,25)+.5)
19252  ! 16/12/09 if(itvol.and.imamin) then
19253  ! 16/12/09 write(12,1009) dav1(i,24),n,dav1(i,1),dav1(i,2),
19254  ! 16/12/09 * dav1(i,38),dav1(i,39)
19255  ! 16/12/09 1009 format(f9.2,' mm Ac. gap ',i3,' length ',f7.2,
19256  ! 16/12/09 * 'mm field ',e12.5,' kV/mm',/,
19257  ! 16/12/09 * ' phase offset adjusted with TOF',/,
19258  ! 16/12/09 * ' before adjustement ',e12.5,' deg',
19259  ! 16/12/09 * ' after adjustement ',e14.7,' deg')
19260  ! 16/12/09 else
19261  write (12, 1008) dav1(i, 24), n, dav1(i, 1), dav1(i, 2), dav1(i, 38)
19262  ! 16/12/09 endif
19263 1008 format (f9.2, ' mm Ac. gap ', i3, ' length ', f7.2, ' mm field ', e12.5, ' kV/mm phase of RF (middle): ', &
19264  e12.5, ' deg')
19265  write (12, *)
19266  end if
19267  ! QUAELEC electric quadrupole
19268  if (iitem(i)==18) then
19269  write (12, 2010) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
19270  dav1(i, 36)
19271 2010 format (f9.2, ' mm Quadrupole (electric): length = ', e12.5, ' mm aperture radius = ', e12.5, ' mm', /, &
19272  ' voltage = ', f8.3, ' kV K2 = ', e12.5, ' cm-2 gradient = ', e12.5, ' kV/(cm*cm) ', /, ' rigidity = ', &
19273  e12.5, ' kV particles left ', f7.0)
19274  write (12, *)
19275  end if
19276  ! QUAFK quadrupole(magnetic or electric)
19277  if (iitem(i)==19) then
19278  ! electric quadrupole
19279  if (ityq) then
19280  write (12, 2110) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
19281  dav1(i, 36)
19282 2110 format (f9.2, ' mm Quadrupole (electric): length = ', e12.5, ' mm aperture radius = ', e12.5, ' mm', /, &
19283  ' voltage = ', e12.5, ' kV K2 = ', e12.5, ' cm-2 gradient = ', e12.5, ' kV/cm2', /, ' rigidity = ', &
19284  e12.5, ' kV particles left ', f7.0)
19285  else
19286  ! magnetic quadrupole
19287  write (12, 2111) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
19288  dav1(i, 36)
19289 2111 format (f9.2, ' mm Quadrupole (magnetic): length = ', e12.5, ' mm aperture radius= ', e12.5, ' mm', /, &
19290  ' field = ', e12.5, ' kG K2 = ', e12.5, ' cm-2 gradient = ', e12.5, ' kG/cm', /, ' momentum = ', e12.5, &
19291  ' kG.cm particles left ', f7.0)
19292  end if
19293  write (12, *)
19294  end if
19295  if (iitem(i)==20) then
19296  ! rotating the transverse coordinates about the z axis
19297  write (12, 2112) dav1(i, 1)
19298 2112 format (9x, 'rotating the transverse coordinates', ' about the z-axis by an angle: ', e12.5, ' deg')
19299  write (12, *)
19300  end if
19301  ! EDFLEC electric deflector
19302  if (iitem(i)==21) then
19303  write (12, 3010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 7), &
19304  dav1(i, 8), dav1(i, 36)
19305 3010 format (f9.2, ' mm Deflector (electric): length = ', e12.5, ' mm bend angle = ', e12.5, ' deg', /, &
19306  ' bend radius = ', e12.5, ' mm radii = ', e12.5, ' field index = ', e12.5, /, ' rigidity = ', e12.5, &
19307  ' kV field = ', e12.5, ' kV/mm', ' particles left ', f7.0)
19308  write (12, *)
19309  end if
19310  ! end (big boucle)
19311  end do
19312  return
19313  end subroutine daves
19314  ! *******************************************************************
19315  ! SUBROUTINE POFAR1(GAP)
19316  ! ENTRANCE OR EXIT OF THE BENDING MAGNET,
19317  ! MATRIX R AND T ARE IN (M,RD)
19318  ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
19319  ! OTHERWIZE DECLARED *********
19320  ! *******************************************************************
19321  subroutine pofar1(gap)
19322  implicit real *8(a-z)
19323  ! -- POLE FACE ROTATION
19324  common /bloc21/be, apb(2), layl, layx, rabt
19325  common /bloc23/h, devi, nb, bdb, l
19326  common /bloc11/r(6, 6), t(6, 6, 6)
19327  common /secdr/iseor
19328  logical iseor
19329  ! H : INVERSE OF THE MAGNET RADIUS (1./CM)
19330  ! NB : DIMENSIONLESS TRANSPORT n coefficient
19331  ! BDB : TRANSPORT beta coefficient
19332  ! APB( ) : HALF GAP (CM)
19333  ! L : LENGTH OF THE MAGNET (CM)
19334  ! BE : ANGLE OF INLINATION (RAD)
19335  ! LAYL : K1 TRANSPORT COEFFICIENT
19336  ! LAYX : K2 TRANSPORT COEFFICIENT
19337  ! RABT : INVERSE OF THE RADIUS OF CURVATURE (1/CM)
19338 
19339  ! SAVE H, GAP AND RABT BEFORE CONVERSION IN M UNITS
19340  sah = h
19341  sarabt = rabt
19342  sagap = gap
19343  h = h*100.
19344  gap = gap*1.e-02
19345  rabt = rabt*100.
19346  tb = tan(be)
19347  cb = cos(be)
19348  sb = (1.0+sin(be)**2)/cb
19349  tcor = 2.0*h*gap*layl
19350  be1 = be - tcor*sb*(1.-layx*tcor*tb)
19351  tb1 = tan(be1)
19352  tb2 = tb**2
19353  r(2, 1) = h*tb
19354  r(4, 3) = -h*tb1
19355  if (.not. iseor) go to 3333
19356  sb = 1./cb
19357  sb2 = sb**2
19358  sb3 = sb2*sb
19359  t(1, 1, 1) = -0.5*h*tb2
19360  t(1, 3, 3) = 0.5*h*sb2
19361  t(2, 1, 1) = 0.5*h*rabt*sb3 - tb*nb*h**2
19362  t(2, 1, 2) = h*tb2
19363  t(2, 1, 6) = -h*tb
19364  t(2, 3, 3) = h**2*(nb+0.5+tb2)*tb - 0.5*h*rabt*sb3
19365  t(2, 3, 4) = -h*tb2
19366  t(3, 1, 3) = h*tb2
19367  t(4, 1, 3) = -h*rabt*sb3 + 2.*h**2*nb*tb
19368  t(4, 1, 4) = -h*tb2
19369  t(4, 2, 3) = -h*sb2
19370  sec2 = cos(be1)*cos(be1)
19371  sec2 = 1./sec2
19372  t(4, 3, 6) = h*tb - h*tcor*sec2
19373 3333 continue
19374  ! RESTORE H , RABT, APB(2)
19375  h = sah
19376  rabt = sarabt
19377  gap = sagap
19378  return
19379  end subroutine pofar1
19380  ! *******************************************************************
19381  ! SUBROUTINE POFAR2(GAP)
19382  ! FIRST AND SECOND order MATRIX R AND T
19383  ! SAVE H, GAP AND RABT BEFORE CONVERSION IN M UNITY
19384  ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
19385  ! OTHERWIZE DECLARED *********
19386  ! *******************************************************************
19387  subroutine pofar2(gap)
19388  implicit real *8(a-z)
19389  ! -- POLE FACE ROTATION
19390  common /bloc21/be, apb(2), layl, layx, rabt
19391  common /bloc23/h, devi, nb, bdb, l
19392  common /bloc11/r(6, 6), t(6, 6, 6)
19393  common /secdr/iseor
19394  logical iseor
19395  ! H : INVERSE OF THE MAGNET RADIUS (1./CM)
19396  ! NB : DIMENSIONLESS TRANSPORT n coefficient
19397  ! BDB : TRANSPORT beta coefficient
19398  ! APB( ) : HALF GAP (CM)
19399  ! L : LENGTH OF THE MAGNET (CM)
19400  ! BE : ANGLE OF INLINATION (RAD)
19401  ! LAYL : K1 TRANSPORT COEFFICIENT
19402  ! LAYX : K2 TRANSPORT COEFFICIENT
19403  ! RABT : INVERSE OF THE RADIUS OF CURVATURE (1/CM)
19404 
19405  sah = h
19406  sarabt = rabt
19407  sagap = gap
19408  h = h*100.
19409  gap = gap*1.e-02
19410  rabt = rabt*100.
19411  tb = tan(be)
19412  cb = cos(be)
19413  sb = (1.0+sin(be)**2)/cb
19414  tcor = 2.0*h*gap*layl
19415  be1 = be - tcor*sb*(1.-layx*tcor*tb)
19416  tb1 = tan(be1)
19417  tb2 = tb**2
19418  r(2, 1) = h*tb
19419  r(4, 3) = -h*tb1
19420  if (.not. iseor) go to 4444
19421  sb = 1./cb
19422  sb2 = sb**2
19423  sb3 = sb2*sb
19424  t(1, 1, 1) = 0.5*h*tb2
19425  t(1, 3, 3) = -0.5*h*sb2
19426  t(2, 1, 1) = 0.5*h*rabt*sb3 - tb*(nb+0.5*tb2)*h**2
19427  t(2, 1, 2) = -h*tb2
19428  t(2, 1, 6) = -h*tb
19429  t(2, 3, 3) = h**2*(nb-0.5*tb2)*tb - 0.5*h*rabt*sb3
19430  t(2, 3, 4) = h*tb2
19431  t(3, 1, 3) = -h*tb2
19432  t(4, 1, 3) = -h*rabt*sb3 + h**2*(2.*nb+sb2)*tb
19433  t(4, 1, 4) = h*tb2
19434  t(4, 2, 3) = h*sb2
19435  sec2 = cos(be1)*cos(be1)
19436  sec2 = 1./sec2
19437  t(4, 3, 6) = h*tb - h*tcor*sec2
19438 4444 continue
19439  ! RESTORE H , RABT, APB(2)
19440  h = sah
19441  rabt = sarabt
19442  gap = sagap
19443  return
19444  end subroutine pofar2
19445  ! *******************************************************************
19446  ! SUBROUTINE BENMAG(sbet,fdtot)
19447  ! IDEAL MAGNET, MATRIX R AND T ARE IN (M,RD)
19448  ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
19449  ! OTHERWIZE DECLARED *********
19450  ! *******************************************************************
19451  subroutine benmag(sbet, fdtot)
19452  implicit real *8(a-z)
19453  ! -- POLE FACE ROTATION
19454  common /bloc21/be, apb(2), layl, layx, rabt
19455  common /bloc23/h, devi, nb, bdb, l
19456  common /bloc11/r(6, 6), t(6, 6, 6)
19457  common /secdr/iseor
19458  logical iseor
19459  ! H : INVERSE OF THE MAGNET RADIUS (1./CM)
19460  ! NB : DIMENSIONLESS TRANSPORT n coefficient
19461  ! BDB : TRANSPORT beta coefficient
19462  ! APB( ) : HALF GAP (CM)
19463  ! L : LENGTH OF THE MAGNET (CM)
19464  ! BE : ANGLE OF INLINATION (RAD)
19465  ! LAYL : K1 TRANSPORT COEFFICIENT
19466  ! LAYX : K2 TRANSPORT COEFFICIENT
19467  ! RABT : INVERSE OF THE RADIUS OF CURVATURE (1/CM)
19468 
19469  ! sbet is relativistic beta of the charge state of interest
19470  sgam2 = 1./(1.-sbet*sbet)
19471  ! SAVE H BEFORE CONVERSION IN m
19472  sah = h
19473  h = h*100.
19474  fieldn = nb
19475  beta = bdb
19476  al = l*1.e-02
19477  rad = 1.0/h
19478  h2 = h*h
19479  h3 = h2*h
19480  h4 = h3*h
19481  h5 = h4*h
19482  h6 = h5*h
19483  kx2 = (1.0-fieldn)*h2
19484  ky2 = fieldn*h2
19485  kx = sqrt(abs(kx2))
19486  ky = sqrt(abs(ky2))
19487  kx3 = kx2*kx
19488  argx = kx*al
19489  argy = ky*al
19490  sinx = sin(argx)
19491  shx = sinh(argx)
19492  al2 = al*al
19493  al3 = al2*al
19494  cx = 0.
19495  sx = 0.
19496  dx = 0.
19497  j1xl = 0.
19498  if (kx2<6.*0) then
19499  cx = cosh(argx)
19500  sx = sinh(argx)/kx
19501  dx = h*(1.0-cx)/kx2
19502  j1xl = (argx-shx)/kx3
19503  end if
19504  if (kx2==6.*0) then
19505  cx = 1
19506  sx = al
19507  dx = h*al2/2.0
19508  j1xl = al3/6.0
19509  end if
19510  if (kx2>6.*0) then
19511  cx = cos(argx)
19512  sx = sin(argx)/kx
19513  dx = h*(1.0-cx)/kx2
19514  j1xl = (argx-sinx)/kx3
19515  end if
19516  cpx = -kx2*sx
19517  spx = cx
19518  dpx = h*sx
19519  cy = 0.
19520  sy = 0.
19521  if (ky2<6.*0) then
19522  cy = cosh(argy)
19523  sy = sinh(argy)/ky
19524  end if
19525  if (ky2==6.*0) then
19526  cy = 1.0
19527  sy = al
19528  end if
19529  if (ky2>6.*0) then
19530  cy = cos(argy)
19531  sy = sin(argy)/ky
19532  end if
19533  cpy = -ky2*sy
19534  spy = cy
19535  ! First order Matrix R
19536  r(1, 1) = cx
19537  r(1, 2) = sx
19538  r(1, 6) = dx
19539  r(2, 1) = cpx
19540  r(2, 2) = spx
19541  r(2, 6) = dpx
19542  r(3, 3) = cy
19543  r(3, 4) = sy
19544  r(4, 3) = cpy
19545  r(4, 4) = spy
19546  r(5, 1) = h*sx
19547  r(5, 2) = dx
19548  r(5, 6) = h2*j1xl
19549  ! Carey eq.2.41 p 34
19550  r(5, 6) = r(5, 6) - al*fdtot/sgam2
19551  ! ************************
19552  if (.not. iseor) go to 3334
19553  ! Second order Matrix T
19554  cosx = cos(argx)
19555  chx = cosh(argx)
19556  kx4 = kx2*kx2
19557  kx6 = kx4*kx2
19558  argy = ky*al
19559  siny = sin(argy)
19560  cosy = cos(argy)
19561  shy = sinh(argy)
19562  chy = cosh(argy)
19563  ky3 = ky2*ky
19564  ky4 = ky2*ky2
19565  targx = argx + argx
19566  sin2x = sin(targx)
19567  cos2x = cos(targx)
19568  sh2x = sinh(targx)
19569  ch2x = cosh(targx)
19570  kx3 = kx*kx2
19571  kx5 = kx3*kx2
19572  kx7 = kx5*kx2
19573  targy = argy + argy
19574  sin2y = sin(targy)
19575  cos2y = cos(targy)
19576  sh2y = sinh(targy)
19577  ch2y = cosh(targy)
19578  al4 = al3*al
19579  al5 = al4*al
19580  al6 = al5*al
19581  al7 = al6*al
19582  c = 1.0/(kx2-4.0*ky2)
19583  j1l = 0.
19584  j2l = 0.
19585  j3l = 0.
19586  j2xl = 0.
19587  j3xl = 0.
19588  j4xl = 0.
19589  j5xl = 0.
19590  j7xl = 0.
19591  j9xl = 0.
19592  j10xl = 0.
19593  j11xl = 0.
19594  j12xl = 0.
19595  j13xl = 0.
19596  j14xl = 0.
19597  j15xl = 0.
19598  j16xl = 0.
19599  j17xl = 0.
19600  if (kx2>6.*0) then
19601  cx = dcos(kx*al)
19602  sx = dsin(kx*al)/kx
19603  dx = h*(1.0d0-cx)/kx2
19604  j1xl = (argx-sinx)/kx3
19605  j2xl = (1.0-cosx-.5*argx*sinx)/kx4
19606  j3xl = .5*(sinx-argx*cosx)/kx3
19607  j4xl = (.5*argx-2.0*sinx/3.0+sin2x/12.)/kx5
19608  j5xl = (.25d0-cosx/3.0+cos2x/12.0)/kx4
19609  j10xl = (argx-1.5*sinx+.5*argx*cosx)/kx5
19610  j11xl = (-2.0*argx+3.0*sinx-argx*cosx)/kx5
19611  j12xl = (4.0*argx-5.5*sinx+1.5*argx*cosx)/kx3
19612  j13xl = (.75-2.0*cosx/3.0-cos2x/12.0-.5*argx*sinx)/kx6
19613  j14xl = (1.5-4.0*cosx/3.0-cos2x/6.0-argx*sinx)/kx6
19614  j15xl = (-1.75+4.0*cosx/3.0+5.0*cos2x/12.0+1.5*argx*sinx)/kx4
19615  j16xl = (1.5*argx-7.0*sinx/3.0-sin2x/12.0+argx*cosx)/kx7
19616  j17xl = (-1.75*argx+17.0*sinx/6.0+5.0*sin2x/24.0-1.5*argx*cosx)/kx5
19617  j1l = (.5*argx-.25*sin2x)/kx3
19618  j2l = (.5*argx+.25*sin2x)/kx
19619  j3l = .25*(1.0-cos2x)/kx2
19620  if (ky2<6.*0) then
19621  j7xl = .5*(argx-sinx+kx2*c*(sinx-.5*kx*sh2y/ky))/(kx3*ky2)
19622  j9xl = c*((cosx-1.0)/kx2+(1.0-ch2y)/(4.0*ky2))
19623  end if
19624  if (ky2==6.*0) then
19625  j7xl = (2.0*(sinx-argx)/kx3+al3/3.0)/kx2
19626  j9xl = al2/(2.0*kx2) + (cosx-1.0)/kx4
19627  end if
19628  if (ky2>6.*0) then
19629  j7xl = .5*(argx-sinx+kx2*c*(sinx-.5*kx*sin2y/ky))/(kx3*ky2)
19630  j9xl = c*((cosx-1.0)/kx2+(1.0-cos2y)/(4.0*ky2))
19631  end if
19632  ! endif kx2.gt.0.
19633  end if
19634  if (kx2<6.*0) then
19635  cx = cosh(kx*al)
19636  sx = sinh(kx*al)/kx
19637  dx = h*(1.0-cx)/kx2
19638  j1xl = (argx-shx)/kx3
19639  j2xl = (1.0-chx+.5*argx*shx)/kx4
19640  j3xl = .5*(shx-argx*chx)/kx3
19641  j4xl = (.5*argx-2.0*shx/3.0+sh2x/12.0)/kx5
19642  j5xl = (.25-chx/3.0+ch2x/12.0)/kx4
19643  j10xl = (argx-1.5*shx+.5*argx*chx)/kx5
19644  j11xl = (-2.0*argx+3.0*shx-argx*chx)/kx5
19645  j12xl = (4.0*argx-5.5*shx+1.5*argx*chx)/kx3
19646  j13xl = (.75-2.0*chx/3.0-ch2x/12.0+.5*argx*shx)/kx6
19647  j14xl = (1.5-4.0*chx/3.0-ch2x/6.0+argx*shx)/kx6
19648  j15xl = (-1.75+4.0*chx/3.0+5.0*ch2x/12.0-1.5*argx*shx)/kx4
19649  j16xl = (1.5*argx-7.0*shx/3.0-sh2x/12.0+argx*chx)/kx7
19650  j17xl = (-1.75*argx+17.0*shx/6.0+5.0*sh2x/24.0-1.5*argx*chx)/kx5
19651  j1l = (.5*argx-.25*sh2x)/kx3
19652  j2l = (.5*argx+.25*sh2x)/kx
19653  j3l = .25*(1.0-ch2x)/kx2
19654  if (ky2<6.*0) then
19655  j7xl = .5*(argx-shx+kx2*c*(shx-.5*kx*sh2y/ky))/(kx3*ky2)
19656  j9xl = c*((chx-1)/kx2+(1.0d0-ch2y)/(4.0d0*ky2))
19657  end if
19658  if (ky2==6.*0) then
19659  j7xl = (2.0*(sinx-argx)/kx3+al3/3.0d0)/kx2
19660  j9xl = al2/(2.0d0*kx2) + (chx-1.0d0)/kx4
19661  end if
19662  if (ky2>6.*0) then
19663  j7xl = .5*(argx-shx+kx2*c*(shx-.5d0*kx*sin2y/ky))/(kx3*ky2)
19664  j9xl = c*((chx-1.0)/kx2+(1.0-cos2y)/(4.0*ky2))
19665  end if
19666  ! end kx2.lt.0.
19667  end if
19668  if (kx2==6.*0) then
19669  cx = 1
19670  sx = al
19671  dx = h*al*al/2.0
19672  j1xl = al3/6.0
19673  j2xl = al4/24.0
19674  j3xl = al3/6.0
19675  j4xl = al5/60.0
19676  j5xl = al4/24.0
19677  j7xl = (al3/12.0-al/(8.0*ky2)-sin2y/(16.0*ky3))/ky2
19678  j10xl = -al5/24.0
19679  j11xl = -al5/60.0
19680  j12xl = al3/6.0
19681  j9xl = al2/(8.0*ky2) - (1.0-cos2y)/(16.0*ky4)
19682  j13xl = al6/240.0
19683  j14xl = al6/1080.0
19684  j15xl = al4/12.0
19685  j16xl = al7/840.0
19686  j17xl = al5/60.0
19687  j1l = al3/3.0
19688  j2l = al
19689  j3l = al2/2.0
19690  ! end kx2.eq.0.
19691  end if
19692  cpx = -kx2*sx
19693  spx = cx
19694  dpx = h*sx
19695  j4l = 0.
19696  j5l = 0.
19697  j6l = 0.
19698  if (ky2<6.*0) then
19699  cy = cosh(ky*al)
19700  sy = sinh(ky*al)/ky
19701  j4l = (.5*argy-.25*sh2y)/ky3
19702  j5l = (.5*argy+.25*sh2y)/ky
19703  j6l = .25*(1.0-ch2y)/ky2
19704  end if
19705  if (ky2==6.*0) then
19706  cy = 1.0
19707  sy = al
19708  j4l = al3/3.0
19709  j5l = al
19710  j6l = al2/2.0
19711  end if
19712  if (ky2>6.*0) then
19713  cy = cos(ky*al)
19714  sy = sin(ky*al)/ky
19715  j4l = (.5*argy-.25*sin2y)/ky3
19716  j5l = (.5*argy+.25*sin2y)/ky
19717  j6l = .25*(1.0-cos2y)/ky2
19718  end if
19719  cpy = -ky2*sy
19720  spy = cy
19721  sy2 = sy*sy
19722  a = 2.0*fieldn - 1.0 - beta
19723  b = (2.0-fieldn)
19724  bn1 = 2.0*fieldn - 1.0 - beta
19725  bn2 = 2.5*fieldn - beta - 1.5
19726  bn3 = 2.0*beta - fieldn
19727  ! tabulation of the integrals (notations TRANSPORT SLAC R-75 table VIb)
19728  i10 = dx/h
19729  i11 = 0.5*al*sx
19730  i111 = 1.0*(sx**2+dx*rad)/3.0
19731  i112 = sx*dx*rad/3.0
19732  i133 = dx/h - (ky2/(kx2-4.0*ky2))*(sy2-2.0*dx*rad)
19733  i134 = c*(sy*cy-sx)
19734  i144 = (sy2-2.0*dx*rad)*c
19735  i20 = sx
19736  i21 = (sx+al*cx)/2.0
19737  i22 = i11
19738  i211 = sx*(1.0+2.0*cx)/3.0
19739  i212 = (2.0*sx**2-dx/h)/3.0
19740  i222 = 2.0*sx*dx*rad/3.0
19741  i233 = sx - 2.0*ky2*(sy*cy-sx)*c
19742  i234 = (kx2*dx*rad-2.0*ky2*sy2)*c
19743  i244 = 2.0*c*(sy*cy-sx)
19744  i33 = 0.5*al*sy
19745  if (ky2==6.*0) i34 = al3/6.0
19746  if (ky2/=6.*0) i34 = 0.5*(sy-al*cy)/ky2
19747  i314 = (2.0*sx*cy-sy*(1.0+cx))*c
19748  i324 = c*(2.0*cy*dx*rad-sx*sy)
19749  i43 = 0.5*(sy+al*cy)
19750  i44 = i33
19751  i413 = c*((kx2-2.0*ky2)*sx*cy-ky2*sy*(1.0+cx))
19752  i414 = c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx))
19753  i424 = c*(cy*sx-cx*sy-2.0*ky2*sy*dx*rad)
19754  i12 = (sx-al*cx)*0.5/kx2
19755  i27 = (dx*rad-.5*al*sx)/kx2
19756  i313 = c*(kx2*cy*dx*rad-2.0*sx*sy*ky2)
19757  i314 = (2.0*sx*cy-sy*(1.0+cx))*c
19758  i324 = c*(2.0*cy*dx*rad-sx*sy)
19759  i43 = 0.5*(sy+al*cy)
19760  i44 = i33
19761  i413 = c*((kx2-2.0*ky2)*sx*cy-ky2*sy*(1.0+cx))
19762  i414 = c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx))
19763  i424 = c*(cy*sx-cx*sy-2.0*ky2*sy*dx*rad)
19764  if (kx/=6.*0) then
19765  i12 = (sx-al*cx)*0.5/kx2
19766  i27 = (dx*rad-.5*al*sx)/kx2
19767  i116 = (0.5*al*sx-(sx**2+dx/h)/3.0)*h/kx2
19768  i122 = (2.0*dx/h-sx**2)/3.0/kx2
19769  i126 = h*(sx+2.0*sx*cx-3.0*al*cx)/6.0/kx2**2
19770  i166 = h2*(4.0*dx*rad/3.0+sx**2/3.0-al*sx)/kx2**2
19771  i216 = h*(al*cx/2.0+sx/6.0-2.0*sx*cx/3.0)/kx2
19772  i226 = h*(0.5*al*sx-2.0*sx**2/3.0+dx*rad/3.0)/kx2
19773  i266 = h2*(sx/3.0+2.0*sx*cx/3.0-al*cx)/kx2**2
19774  i323 = c*(2.0*ky2*sy*(1.0+cx)/kx2-sx*cy) + sy/kx2
19775  i336 = h*(0.5*al*sy-c*(cy*(1.0-cx)-2.0*ky2*sx*sy))/kx2
19776  i346 = h*(i34-c*(2.0*sx*cy-sy*(1.0+cx)))/kx2
19777  i423 = c*(2.0*ky2*cy*(1.0+cx)/kx2-cx*cy-ky2*sx*sy) + cy/kx2
19778  i436 = h*(0.5*al*cy+0.5*sy+c*(ky2*sy*(1.0+cx)-(kx2-2.0*ky2)*sx*cy))/kx2
19779  i446 = h*(al*sy*0.5-c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx)))/kx2
19780  i26 = i12*h
19781  else
19782  i12 = al3/6.0
19783  i27 = al4/12.0
19784  i116 = h*al4/24.0
19785  i122 = al4/12.0
19786  i126 = h*al5/40.0
19787  i166 = h2*al2/120.0
19788  i216 = h*al3/6.0
19789  i226 = h*al4/8.0
19790  i266 = h2*al5/20.0
19791  i323 = al2*sy/4.0
19792  i336 = h*al*(al2*sy/12.0+(al*cy-sy)/(ky2*8.0))
19793  i346 = h*al2*(sy/(ky2*8.0)-al*cy/(ky2*12.0))
19794  i423 = (al2*cy+al*sy)/4.0
19795  i436 = h*al2*(sy/8.0+cy*al/12.0)
19796  i446 = h*al*(al2*sy/12.0+(sy-al*cy)/(ky2*8.0))
19797  i26 = i12*h
19798  end if
19799  ! MATRIX T(i,j,k), TRANSPORT SLAC R-75 table VIa
19800 
19801  t(1, 1, 1) = a*h3*i111 + 0.5*kx2**2*i122*h
19802  t(1, 1, 2) = 2.0*a*h3*i112 - kx2*h*i112 + h*sx
19803  t(1, 1, 6) = b*h2*i11 + 2.0*a*h3*i116 - kx2*h2*i122
19804  t(1, 2, 2) = a*h3*i122 + 0.5*h*i111
19805  t(1, 2, 6) = b*h2*i12 + 2.0*a*h3*i126 + h2*i112
19806  t(1, 3, 3) = beta*h3*i133 - 0.5*ky2*h*i10
19807  t(1, 3, 4) = 2.0*beta*h3*i134
19808  t(1, 4, 4) = beta*h3*i144 - 0.5*h*i10
19809  t(1, 6, 6) = b*h2*h*i27 + a*h3*i166 + 0.5d0*h3*i122 - h*i10
19810 
19811  t(2, 1, 1) = a*h3*i211 + 0.5*kx2**2*h*i222 - h*cx*cpx
19812  t(2, 1, 2) = h*spx + 2.0d0*a*h3*i212 - kx2*h*i212 - h*(cx*spx+cpx*sx)
19813  t(2, 1, 6) = b*h2*i21 + 2.0*a*h3*i216 - kx2*h2*i222 - h*(cx*dpx+cpx*dx)
19814  t(2, 2, 2) = a*h3*i222 + 0.5*h*i211 - h*sx*spx
19815  t(2, 2, 6) = b*h2*i22 + 2.0*a*h3*i226 + h2*i212 - h*(sx*dpx+spx*dx)
19816  t(2, 3, 3) = beta*h3*i233 - 0.5*ky2*h*i20
19817  t(2, 3, 4) = 2.0*beta*h3*i234
19818  t(2, 4, 4) = beta*h3*i244 - 0.5*h*i20
19819  t(2, 6, 6) = b*h2*i26 + a*h3*i266 + 0.5*h3*i222 - h*dx*dpx - h*i20
19820 
19821  ! VALUE OF "B" IS CHANGED.
19822 
19823  b = beta - fieldn
19824 
19825  t(3, 1, 3) = 2.0*b*h3*i313 + kx2*ky2*h*i324
19826  t(3, 1, 4) = h*sy + 2.0d0*b*h3*i314 - kx2*h*i323
19827  t(3, 2, 3) = 2.0*b*h3*i323 - ky2*h*i314
19828  t(3, 2, 4) = 2.0*b*h3*i324 + h*i313
19829  t(3, 3, 6) = ky2*i33 + 2.0*b*h3*i336 - ky2*h2*i324
19830  t(3, 4, 6) = ky2*i34 + 2.0*b*h3*i346 + h2*i323
19831 
19832  t(4, 1, 3) = 2.0*b*h3*i413 + kx2*ky2*h*i424 - h*cx*cpy
19833  t(4, 1, 4) = h*spy + 2.0*h3*b*i414 - kx2*h*i423 - h*cx*spy
19834  t(4, 2, 3) = 2.0*b*h3*i423 - ky2*h*i414 - h*sx*cpy
19835  t(4, 2, 4) = 2.0*b*h3*i424 + h*i413 - h*sx*spy
19836  t(4, 3, 6) = ky2*i43 + 2.0*b*h3*i436 - ky2*h2*i424 - h*dx*cpy
19837  t(4, 4, 6) = ky2*i44 + 2.0*b*h3*i446 + h2*i423 - h*dx*spy
19838 
19839  t(5, 1, 1) = h4*(bn1*j1xl-bn2*kx2*j4xl) + .5*kx4*j1l
19840  t(5, 1, 2) = h4*2.0*bn2*j5xl - kx2*j3l + h*dx
19841  t(5, 1, 6) = h5*j11xl + h3*j12xl + h*kx2*j3xl + h5*2.0*bn2*j4xl + 2.0*beta*h5*j10xl - h*kx2*j1l
19842  ! Carey eq. 7.45 p.143
19843  t(5, 1, 6) = t(5, 1, 6) - r(5, 1)/sgam2
19844 
19845  t(5, 2, 2) = .5*(h2*j1xl+h4*2.0*bn2*j4xl+j2l)
19846  t(5, 2, 6) = -2.0*beta*h5*j13xl + h5*j14xl + h3*j15xl + h*kx2*j2xl + h*j3l
19847  ! Carey eq. 7.45 p.143
19848  t(5, 2, 6) = t(5, 2, 6) - r(5, 2)/sgam2
19849 
19850  t(5, 3, 3) = .5*(h4*(bn3*j1xl-2.0*beta*ky2*j7xl)+ky4*j4l)
19851  t(5, 3, 4) = 2.0*beta*h4*j9xl - ky2*j6l
19852  t(5, 4, 4) = beta*h4*j7xl - .5*(h2*j1xl-j5l)
19853  t(5, 6, 6) = (1.0-beta)*h6*j16xl + h4*j17xl - h2*j3xl + .5*h2*j1l
19854  ! Carey eq. 7.45 p.143
19855  t(5, 6, 6) = t(5, 6, 6) - r(5, 6)/sgam2
19856  t(5, 6, 6) = t(5, 6, 6) + al*((1./sgam2)**2+1.5*sbet*sbet/sgam2)
19857  ! Carey eq.7.46 p.143
19858  t(5, 5, 6) = -1./sgam2
19859 3334 continue
19860  ! RESTORE H
19861  h = sah
19862  return
19863  end subroutine benmag
19864  ! *******************************************************************
19865  ! SUBROUTINE syrout(ii)
19866  ! SYNCHROTRON RADIATION EXCITATION FOR PARTICLE ii
19867  ! The method is described in 'synchrotron radiation in DYNAC'
19868  ! *******************************************************************
19869  subroutine syrout(ii)
19870  implicit real *8(a-h, o-z)
19871  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
19872  common /consta/vl, pi, xmat, rpel, qst
19873  common /faisc/f(10, iptsz), imax, ngood
19874  common /bloc11/r(6, 6), t(6, 6, 6)
19875  common /radia/trt, rmoy, xintf, crae
19876  ! *************************************************************************************
19877  ! Synchrotron radiation
19878  ! COMMON/RADIA/TRT,RMOY,XINTF,CRAE
19879  ! TRT : t.o.f in sec for a particle crossing the bending magnet
19880  ! RMOY : average radius of the bending magnet in the magnetic plane
19881  ! XINTF : integral of (u/uc) * S(u/uc) where S(u/uc) is the spectral function
19882  ! ( see Synchrotron radiation in DYNAC)
19883  ! CRAE : classical electron radius (cm)
19884  ! ***************************************************************************************
19885  ! PGAM : Instantaneous radiation power (MeV/sec)
19886  ! ETA : eta=u/uc
19887  ! uc : critical quanta energy (eV)
19888  ! u : quanta energy (eV) considered
19889  ! the most significant quanta are assumed emitted between: 0.1<eta<3.
19890  e4ii = f(7, ii)**4
19891  gpaii = f(7, ii)/xmat
19892  cgam = (4.*pi/3.)*crae/(xmat**3)
19893  pgam = vl*cgam*e4ii/(2.*pi*rmoy*rmoy)
19894  ! ELOST : Total energy lost due to radiation (MeV)
19895  elost = xintf*pgam*trt
19896  ! variation of the momentum (only available for relativistic electrons)
19897  dmo = -elost/f(7, ii)
19898  ! change the total energy (MeV)
19899  f(7, ii) = f(7, ii) - elost
19900  ! change f(2,ii) and f(3,ii)
19901  ! dmo*r(1,6) is given in m and dmo*r(2,6) in rad, convert in cm and mrad
19902  f(2, ii) = f(2, ii) + dmo*r(1, 6)*100.
19903  f(3, ii) = f(3, ii) + dmo*r(2, 6)*1000.
19904  return
19905  end subroutine syrout
19906  ! *******************************************************************
19907  ! SUBROUTINE syref
19908  ! SYNCHROTRON RADIATION EXCITATION FROM PARTICLE REFERENCE
19909  ! The method is described in 'synchrotron radiation in DYNAC'
19910  ! *******************************************************************
19911  subroutine syref
19912  implicit real *8(a-h, o-z)
19913  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
19914  common /consta/vl, pi, xmat, rpel, qst
19915  common /radia/trt, rmoy, xintf, crae
19916  common /dyn/tref, vref
19917  common /bloc23/h, devi, nb, bdb, l
19918  common /itvole/itvol, imamin
19919  common /tofev/ttvols
19920  logical itvol, imamin
19921  real *8 l, nb
19922 
19923  beref = vref/vl
19924  gamref = 1./sqrt(1.-beref*beref)
19925  ener = xmat*gamref*beref
19926  trt = l/vref
19927  e4 = ener**4
19928  cgam = (4.*pi/3.)*crae/(xmat**3)
19929  pgam = vl*cgam*e4/(2.*pi*rmoy*rmoy)
19930  ! ELOST : Total energy lost due to radiation (MeV)
19931  ! change vref and tref of the reference
19932  elost = xintf*pgam*trt
19933  fener = ener - elost
19934  fgam = fener/xmat
19935  fberef = sqrt(1.-1./(fgam*fgam))
19936  vref = fberef*vl
19937  tref = tref + l/vref
19938  if (itvol) ttvols = tref
19939  write (16, 250) elost, ener, fener
19940 250 format (//, ' REFERENCE AFTER RADIATION EXITATION*****', /, ' ENERGY LOST (MeV): ', e12.5, /, &
19941  ' OLD ENERGY (MeV): ', e12.5, /, ' NEW ENERGY (MeV): ', e12.5)
19942  return
19943  end subroutine syref
19944  ! *******************************************************************
19945  ! SUBROUTINE sextu(imk2,arg,xlsex,rg)
19946  ! magnetic sextupole
19947  ! space charge at the middle of the lens
19948  ! *******************************************************************
19949  subroutine sextu(imk2, arg, xlsex, rg)
19950  implicit real *8(a-h, o-z)
19951  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
19952  common /fene/wdisp, wphas, wx, wy, rlim, ifw
19953  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
19954  common /dyn/tref, vref
19955  common /consta/vl, pi, xmat, rpel, qst
19956  common /rigid/boro
19957  common /faisc/f(10, iptsz), imax, ngood
19958  common /etcom/cog(8), exten(17), fd(iptsz)
19959  common /qmoyen/qmoy
19960  common /dcspa/iesp
19961  logical iesp
19962  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
19963  logical ichaes
19964  common /tapes/in, ifile, meta
19965  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
19966  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
19967  common /shif/dtiph, shift
19968  logical shift
19969  common /compt/nrres, nrtre, nrbunc, nrdbun
19970  common /rander/ialin
19971  logical ialin
19972  common /qskew/qtwist, iqrand, itwist, iaqu
19973  logical itwist
19974  common /femt/iemgrw, iemqesg
19975  logical iemgrw
19976  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
19977  common /qsex/l, kq2, ks2
19978  real *8 l, kq2, ks2
19979  character *1 cr
19980  dimension trans(2)
19981 
19982  ilost = 0
19983  write (16, *) ' ******SEXTUPOLE*********'
19984  ! statistics
19985  if (iprf==1) call stapl(davtot*10.)
19986  nrtre = nrtre + 1
19987  cr = char(13)
19988  ! print out on terminal of transport element # on one and the same line
19989  write (6, 8254) nrtre, nrres, cr
19990 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
19991  len = 1
19992  ! if itwist=.true. skews the sextupole before misalignments
19993  sqtwist = 0.
19994  if (itwist .and. arg/=0.) then
19995  if (iqrand==0) then
19996  qtwrad = qtwist
19997  sqtwist = qtwrad
19998  call zrotat(qtwrad)
19999  else
20000  rdcf = .5
20001  call rlux(trans, len)
20002  if (trans(1)<=rdcf) sign = -1.
20003  if (trans(1)>rdcf) sign = 1.
20004  call rlux(trans, len)
20005  qtwrad = qtwist*sign*trans(1)
20006  sqtwist = qtwrad
20007  call zrotat(qtwrad)
20008  end if
20009  end if
20010  if (ialin) call randali
20011  fh0 = fh/vl
20012  write (16, *) 'TOF at input:', tref*fh*180./pi, ' deg'
20013 
20014  gpa = 0.
20015  do ii = 1, ngood
20016  gpa = gpa + f(7, ii)/xmat
20017  end do
20018  gpa = gpa/float(ngood)
20019  l = xlsex
20020  bpa = sqrt(1.-1./(gpa*gpa))
20021  xmco = xmat*bpa*gpa
20022  ri = 33.356*xmco*1.e-01/qst
20023  if (imk2/=0) then
20024  ! arg: field B (kG)
20025  fb = arg
20026  b = arg/(rg*rg)
20027  ks2 = b/ri
20028  else
20029  ! arg: KS2 (cm-3)
20030  ks2 = arg
20031  b = ks2*ri
20032  fb = b*(rg*rg)
20033  end if
20034  write (16, 3300) xlsex, rg, fb, ks2, b, ri
20035 3300 format (' LENGTH = ', e12.3, ' cm APERTURE RADIUS= ', e12.5, ' cm', /, ' FIELD = ', e12.5, ' kG KS2 = ', e12.5, &
20036  ' cm-3', ' GRADIENT = ', e12.5, ' kG/(cm*cm)', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
20037  call clear
20038  call elsex
20039  ! print transport matrix (c.o.g.)
20040  call matrix
20041  ! start daves
20042  idav = idav + 1
20043  iitem(idav) = 10
20044  dav1(idav, 1) = xlsex*10.
20045  dav1(idav, 2) = b
20046  dav1(idav, 3) = fb
20047  davtot = davtot + xlsex
20048  dav1(idav, 4) = davtot*10.
20049  dav1(idav, 5) = ks2
20050  dav1(idav, 6) = rg
20051  dav1(idav, 7) = ri
20052  ! first half sextupole
20053  l = xlsex/2.
20054  do ii = 1, ngood
20055  call clear
20056  gpai = f(7, ii)/xmat
20057  bpai = sqrt(1.-1./(gpai*gpai))
20058  xmco = xmat*bpai*gpai
20059  ri = 33.356*xmco*1.e-01/f(9, ii)
20060  ks2 = b/ri
20061  call elsex
20062  call cobeam(ii, l)
20063  ! the evolution of the t.o.f is made in routine cobeam)
20064  ! omment f(6,ii)=f(6,ii)+l/(bpai*vl)
20065  end do
20066  ! Charge space effect (if dl >0)
20067  if (ichaes .and. l>0.) then
20068  if (sce10==1 .or. sce10==3.) then
20069  iesp = .true.
20070  write (16, *) 'space charge at the middle '
20071  call cesp(xlsex)
20072  iesp = .false.
20073  end if
20074  end if
20075  bcour = 0.
20076  do i = 1, ngood
20077  gpai = f(7, i)/xmat
20078  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
20079  end do
20080  bcour = bcour/float(ngood)
20081  gcour = 1./sqrt(1.-bcour*bcour)
20082  wcg = (gcour-1.)*xmat
20083  ! ----- convert wdisp in dp/p (window control)
20084  ! ---- ifw = 0 ===> wdisp = dW/W
20085  ! ---- ifw = 1 ===> wdisp = dW (MeV)
20086  if (ifw==0) dispr = gcour*gcour*wdisp/(gcour*(gcour+1.))
20087  if (ifw==1) dispr = gcour*gcour*wdisp/(gcour*(gcour+1.)*wcg)
20088  ! ---- Change the dispersion with the new energy
20089  do i = 1, ngood
20090  gpai = f(7, i)/xmat
20091  bpai = sqrt(1.-1./(gpai*gpai))
20092  fd(i) = bpai/bcour*gpai/gcour
20093  end do
20094  ! Test window after the first half sextupole
20095  call cogetc
20096  ! Change the t.o.f of the reference
20097  tref = tref + xlsex/(2.*vref)
20098  call reject(nlost)
20099  ! Reshuffles f(i,j) array after window (now done in 'reject')
20100  ! call shuffle
20101  call shuffle
20102  ! second half sextupole
20103  do ii = 1, ngood
20104  call clear
20105  gpai = f(7, ii)/xmat
20106  bpai = sqrt(1.-1./(gpai*gpai))
20107  xmco = xmat*bpai*gpai
20108  ri = 33.356*xmco*1.e-01/f(9, ii)
20109  ks2 = b/ri
20110  call elsex
20111  call cobeam(ii, l)
20112  end do
20113  ! Test window after the second half sextupole (only in transverse directions and phase)
20114  call cogetc
20115  ! Change the t.o.f of the reference
20116  tref = tref + xlsex/(2.*vref)
20117  call reject(ilost)
20118  ilost = ilost + nlost
20119  ! Reshuffles f(i,j) array after window (now done in 'reject')
20120  ! call shuffle
20121  dav1(idav, 36) = ngood
20122  write (16, *) 'TOF at output:', tref*fh*180./pi, ' deg'
20123  write (16, *) ' particles lost in sextupole :', ilost
20124  ! returns coordinates to the initial orientation
20125  if (itwist .and. b/=0.) then
20126  qtwrad = -sqtwist
20127  call zrotat(qtwrad)
20128  end if
20129  if (iemgrw) call emiprt(0)
20130  call stapl(davtot*10.)
20131  return
20132  end subroutine sextu
20133  ! *******************************************************************
20134  ! SUBROUTINE qalva(bquad,xlqua,rg)
20135  ! QUADRUPOLE
20136  ! space charge computations at the middle of the lens
20137  ! BQUAD: field at pole tip (kG)
20138  ! If BQUAD positive = focalisation in the H-plane (x,z)
20139  ! XLQUA: EFFECTIVE LENGHT (cm )
20140  ! RG: APERTURE RADIUS (cm)
20141  ! *******************************************************************
20142  subroutine qalva(bquad, xlqua, rg)
20143  implicit real *8(a-h, o-z)
20144  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20145  common /fene/wdisp, wphas, wx, wy, rlim, ifw
20146  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
20147  common /dyn/tref, vref
20148  common /consta/vl, pi, xmat, rpel, qst
20149  common /rigid/boro
20150  common /faisc/f(10, iptsz), imax, ngood
20151  common /etcom/cog(8), exten(17), fd(iptsz)
20152  common /qmoyen/qmoy
20153  common /dcspa/iesp
20154  logical iesp
20155  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
20156  logical ichaes
20157  common /tapes/in, ifile, meta
20158  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
20159  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
20160  common /shif/dtiph, shift
20161  logical shift
20162  common /compt/nrres, nrtre, nrbunc, nrdbun
20163  common /rander/ialin
20164  logical ialin
20165  common /qskew/qtwist, iqrand, itwist, iaqu
20166  logical itwist
20167  common /femt/iemgrw, iemqesg
20168  logical iemgrw
20169  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20170  common /qsex/l, kq2, ks2
20171  common /tofev/ttvols
20172  common /itvole/itvol, imamin
20173  logical itvol, imamin
20174  real *8 l, kq2, ks2
20175  dimension trans(1)
20176  character *1 cr
20177  ! print out on terminal of transport element # on one and the same line
20178  nrtre = nrtre + 1
20179  cr = char(13)
20180  write (6, 8254) nrtre, nrres, cr
20181 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
20182  ilost = 0
20183  ! B : GRADIENT IN kG/cm
20184  b = bquad/rg
20185  ! statistics
20186  if (iprf==1) call stapl(davtot*10.)
20187  write (16, *) ' ***QUADRUPOLE (magnetic) ***'
20188  fcpi = fh*180./pi
20189  if (itvol) write (16, 10) ttvols*fcpi, davtot
20190 10 format (' ** TOF (input of the lens): ', e12.5, ' deg at: ', e12.5, ' cm in the lattice')
20191  ! if itwist=.true: skews the quadrupole before misalignments (if b ne 0)
20192  ! len = 1 level in rlux routine
20193  len = 1
20194  if (itwist .and. b/=0.) then
20195  if (iqrand==0) then
20196  qtwrad = qtwist
20197  sqtwist = qtwrad
20198  call zrotat(qtwrad)
20199  else
20200  rdcf = .5
20201  call rlux(trans, len)
20202  if (trans(1)<=rdcf) sign = -1.
20203  if (trans(1)>rdcf) sign = 1.
20204  call rlux(trans, len)
20205  qtwrad = qtwist*sign*trans(1)
20206  sqtwist = qtwrad
20207  call zrotat(qtwrad)
20208  end if
20209  else
20210  sqtwist = 0.
20211  end if
20212  if (ialin) call randali
20213  fh0 = fh/vl
20214  ! print transport matrix (cog)
20215  gpa = 0.
20216  do ii = 1, ngood
20217  gpa = gpa + f(7, ii)/xmat
20218  end do
20219  gpa = gpa/float(ngood)
20220  l = xlqua
20221  bpa = sqrt(1.-1./(gpa*gpa))
20222  xmco = xmat*bpa*gpa
20223  ri = 33.356*xmco*1.e-01/qst
20224  kq2 = b/ri
20225  call clear
20226  call elqua
20227  write (16, 3300) xlqua, rg, bquad, kq2, b, ri
20228 3300 format (' LENGTH = ', e12.5, ' cm APERTURE RADIUS= ', e12.5, ' cm', /, ' FIELD = ', e12.5, ' kG K2 = ', e12.5, &
20229  ' cm-2 ', ' GRADIENT = ', e12.5, ' kG/cm', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
20230  call matrix
20231  ! Daves start
20232  idav = idav + 1
20233  iitem(idav) = 2
20234  dav1(idav, 1) = xlqua*10.
20235  dav1(idav, 2) = bquad
20236  davtot = davtot + xlqua
20237  dav1(idav, 4) = davtot*10.
20238  dav1(idav, 3) = kq2
20239  dav1(idav, 5) = b
20240  dav1(idav, 6) = ri
20241  dav1(idav, 7) = rg*10.
20242  ! first half quadrupole
20243  l = xlqua/2.
20244  do ii = 1, ngood
20245  call clear
20246  gpai = f(7, ii)/xmat
20247  bpai = sqrt(1.-1./(gpai*gpai))
20248  xmco = xmat*bpai*gpai
20249  ri = 33.356*xmco*1.e-01/f(9, ii)
20250  kq2 = b/ri
20251  call elqua
20252  call cobeam(ii, l)
20253  end do
20254  ! Charge space computations (if dl >0)
20255  if (ichaes .and. l>0.) then
20256  if (sce10==1 .or. sce10==3.) then
20257  iesp = .true.
20258  write (16, *) 'space charge at the middle '
20259  call cesp(xlqua)
20260  iesp = .false.
20261  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
20262  call disp
20263  end if
20264  end if
20265  ! Test window after the first half quadrupole (after s.c. computations)
20266  call cogetc
20267  bcour = 0.
20268  do i = 1, ngood
20269  gpai = f(7, i)/xmat
20270  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
20271  end do
20272  bcour = bcour/float(ngood)
20273  gcour = 1./sqrt(1.-bcour*bcour)
20274  wcg = (gcour-1.)*xmat
20275  ! ----- window control
20276  ! Change the t.o.f of the reference
20277  tref = tref + xlqua/(2.*vref)
20278  call reject(nlost)
20279  ! Reshuffles f(i,j) array after window (now done in 'reject')
20280  ! call shuffle
20281  ! second half quadrupole
20282  do ii = 1, ngood
20283  call clear
20284  gpai = f(7, ii)/xmat
20285  bpai = sqrt(1.-1./(gpai*gpai))
20286  xmco = xmat*bpai*gpai
20287  ri = 33.356*xmco*1.e-01/f(9, ii)
20288  kq2 = b/ri
20289  call elqua
20290  ! ********CONTROL :print matrix for particle number 1 (only for tests)
20291  ! omment if(ii.eq.1) then
20292  ! omment write(16,*) ' *****second half quadrupole'
20293  ! omment xkq2=sqrt(abs(kq2))
20294  ! omment xkql=xkq2*l*57.29578
20295  ! omment write(16,3300) ri,xkq2,xkql
20296  ! omment call matrix
20297  ! omment endif
20298  call cobeam(ii, l)
20299  end do
20300  ! Test window after the second half quadrupole
20301  call cogetc
20302  ! Change the t.o.f of the reference
20303  tref = tref + xlqua/(2.*vref)
20304  call reject(ilost)
20305  ilost = ilost + nlost
20306  ! Reshuffles f(i,j) array after window (now done in 'reject')
20307  ! call shuffle
20308  if (itvol) ttvols = tref
20309  tcog = 0.
20310  do i = 1, ngood
20311  tcog = tcog + f(6, i)
20312  end do
20313  tcog = tcog/float(ngood)
20314  if (itvol) then
20315  write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
20316 11 format (' ** tof: ', e12.5, ' deg at: ', e12.5, ' cm in the lattice', /, 3x, 'tof of the reference: ', e12.5, &
20317  ' deg tof of the cog: ', e12.5, ' deg')
20318  else
20319  write (16, 12) tref*fcpi, tcog*fcpi
20320 12 format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
20321  end if
20322  dav1(idav, 36) = ngood
20323  write (16, *) ' particles lost in quadrupole :', ilost
20324  ! returns coordinates to the initial orientation
20325  if (itwist .and. b/=0.) then
20326  qtwrad = -sqtwist
20327  call zrotat(qtwrad)
20328  end if
20329  if (iemgrw) call emiprt(0)
20330  ! envelope
20331  call stapl(davtot*10.)
20332  return
20333  end subroutine qalva
20334  ! *******************************************************************
20335  ! SUBROUTINE qasex(iksq,args,argq,xlqua,rg)
20336  ! quadrupole associated sextupole field
20337  ! space charge computation at the middle of the lens
20338  ! IKSQ: IFLAG (see ARGS and ARGQ)
20339  ! ARGS: strength of SEXTUPOLE
20340  ! IKSQ = 0, then ARGS =KS2 (cm-3), otherwise ARGS = FIELD FS(kG)
20341  ! ARGQ: strength of QUADRUPOLE
20342  ! If IKSQ = 0, then ARGQ=KQ2 (cm-2), otherwise ARGQ = FIELD FQ(kG)
20343  ! XLQUA : EFFECTIVE LENGHT OF THE LENS(cm)
20344  ! RG : APERTURE RADIUS OF THE LENS (cm)
20345  ! *******************************************************************
20346  subroutine qasex(iksq, args, argq, xlqua, rg)
20347  implicit real *8(a-h, o-z)
20348  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20349  common /fene/wdisp, wphas, wx, wy, rlim, ifw
20350  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
20351  common /dyn/tref, vref
20352  common /consta/vl, pi, xmat, rpel, qst
20353  common /rigid/boro
20354  common /faisc/f(10, iptsz), imax, ngood
20355  common /etcom/cog(8), exten(17), fd(iptsz)
20356  common /qmoyen/qmoy
20357  common /dcspa/iesp
20358  logical iesp
20359  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
20360  logical ichaes
20361  common /tapes/in, ifile, meta
20362  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
20363  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
20364  common /shif/dtiph, shift
20365  logical shift
20366  common /compt/nrres, nrtre, nrbunc, nrdbun
20367  common /rander/ialin
20368  logical ialin
20369  common /qskew/qtwist, iqrand, itwist, iaqu
20370  logical itwist
20371  common /femt/iemgrw, iemqesg
20372  logical iemgrw
20373  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20374  common /qsex/l, kq2, ks2
20375  real *8 l, kq2, ks2
20376  character *1 cr
20377  ! print out on terminal of transport element # on one and the same line
20378  nrtre = nrtre + 1
20379  cr = char(13)
20380  write (6, 8254) nrtre, nrres, cr
20381 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
20382  rgorge = rg
20383  ilost = 0
20384  ! statistics
20385  if (iprf==1) call stapl(davtot*10.)
20386  ! if itwist=.true. skews the quasex before misalignments
20387  ! omment len=1
20388  ! omment if(itwist.and.b.ne.0.) then
20389  ! omment if(iqrand.eq.0) then
20390  ! omment qtwrad=qtwist
20391  ! omment sqtwist=qtwrad
20392  ! omment call zrotat(qtwrad)
20393  ! omment else
20394  ! omment rdcf=.5
20395  ! omment call rlux(trans,len)
20396  ! omment if(trans.le.rdcf) sign=-1.
20397  ! omment if(trans.gt.rdcf) sign=1.
20398  ! omment call rlux(trans,len)
20399  ! omment qtwrad=qtwist*sign*trans
20400  ! omment sqtwist=qtwrad
20401  ! omment call zrotat(qtwrad)
20402  ! omment endif
20403  ! omment endif
20404  ! misalignments
20405  if (ialin) call randali
20406  gpa = 0.
20407  do ii = 1, ngood
20408  gpa = gpa + f(7, ii)/xmat
20409  end do
20410  gpa = gpa/float(ngood)
20411  l = xlqua
20412  bpa = sqrt(1.-1./(gpa*gpa))
20413  xmco = xmat*bpa*gpa
20414  ri = 33.356*xmco*1.e-01/qst
20415  if (iksq/=0) then
20416  ! --- quadrupole: argq = field fq (kG)
20417  fq = argq
20418  bq = fq/rg
20419  ! kq2: strength (cm-2)
20420  kq2 = bq/ri
20421  ! --- sextupole: args = field fs (kG)
20422  fs = args
20423  bs = fs/(rg*rg)
20424  ! ks2 strength (cm-3)
20425  ks2 = bs/ri
20426  else
20427  ! --- quadrupole: argq is kq2 (cm-2)
20428  kq2 = argq
20429  fq = kq2*rg*ri
20430  bq = kq2*ri
20431  ! --- sextupole: args is ks2 (cm-3)
20432  ks2 = args
20433  bs = ks2*ri
20434  fs = bs*(rg*rg)
20435  end if
20436  call clear
20437  call elqsex
20438  write (16, *) ' *****LENS QUADRUPOLE+SEXTUPOLE ********'
20439  write (16, 3300) xlqua, rg, fq, kq2, bq, fs, ks2, bs, ri
20440 3300 format (' LENS: LENGTH = ', e12.5, ' cm APERTURE RADIUS = ', e12.5, ' cm', /, ' QUADRUPOLE: FIELD = ', e12.5, &
20441  ' kG KQ2 = ', e12.5, ' cm-2 GRADIENT = ', e12.5, ' kG/cm', /, ' SEXTUPOLE: FIELD = ', e12.5, ' kG KS2 = ', &
20442  e12.5, ' cm-3', ' GRADIENT = ', e12.5, ' kG/(cm*cm)', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
20443  fh0 = fh/vl
20444  write (16, *) 'TOF at input:', tref*fh*180./pi, ' deg'
20445  ! print transport matrix (c.o.g.)
20446  call matrix
20447  ! start Daves
20448  idav = idav + 1
20449  iitem(idav) = 12
20450  dav1(idav, 1) = xlqua*10.
20451  dav1(idav, 6) = rg*10.
20452  dav1(idav, 2) = fq
20453  dav1(idav, 3) = kq2
20454  ! gradient (quad) dav1(idav,5)=bq
20455  dav1(idav, 7) = fs
20456  dav1(idav, 8) = ks2
20457  ! gradient (sol) dav1(idav,9)=bs
20458  dav1(idav, 10) = ri
20459  davtot = davtot + xlqua
20460  dav1(idav, 4) = davtot*10.
20461  ! first half quasex
20462  l = xlqua/2.
20463  do ii = 1, ngood
20464  call clear
20465  gpai = f(7, ii)/xmat
20466  bpai = sqrt(1.-1./(gpai*gpai))
20467  xmco = xmat*bpai*gpai
20468  ri = 33.356*xmco*1.e-01/f(9, ii)
20469  kq2 = bq/ri
20470  ks2 = bs/ri
20471  call elqsex
20472  ! ********CONTROL :print matrix for particle number 1 (only for tests)
20473  ! omment if(ii.eq.5) then
20474  ! omment write(16,*) ' *****first half quasex'
20475  ! omment xkq2=sqrt(abs(kq2))
20476  ! omment xkql=xkq2*l*57.29578
20477  ! omment xks=sqrt(abs(ks2))
20478  ! omment xksl=xks*l**(1.5)*57.29578
20479  ! omment write(16,3300) ri,xkq2,xkql,xks,xksl
20480  ! omment call matrix
20481  ! omment endif
20482  ! ********END CONTROL
20483  call cobeam(ii, l)
20484  end do
20485  ! Charge space effect (if dl >0)
20486  if (ichaes .and. l>0.) then
20487  if (sce10==1 .or. sce10==3.) then
20488  iesp = .true.
20489  write (16, *) 'space charge at the middle '
20490  call cesp(xlqua)
20491  iesp = .false.
20492  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
20493  call disp
20494  end if
20495  end if
20496  ! Test window after the first half quasex (after s.c. computations)
20497  bcour = 0.
20498  do i = 1, ngood
20499  gpai = f(7, i)/xmat
20500  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
20501  end do
20502  bcour = bcour/float(ngood)
20503  gcour = 1./sqrt(1.-bcour*bcour)
20504  wcg = (gcour-1.)*xmat
20505  ! ----- window control
20506  call cogetc
20507  ! Change the t.o.f of the reference
20508  tref = tref + xlqua/(2.*vref)
20509  call reject(nlost)
20510  ! Reshuffles f(i,j) array after window (now done in 'reject')
20511  ! call shuffle
20512  ! second half quasex
20513  do ii = 1, ngood
20514  call clear
20515  gpai = f(7, ii)/xmat
20516  bpai = sqrt(1.-1./(gpai*gpai))
20517  xmco = xmat*bpai*gpai
20518  ri = 33.356*xmco*1.e-01/f(9, ii)
20519  kq2 = bq/ri
20520  ks2 = bs/ri
20521  call elqsex
20522  ! ********CONTROL :print matrix for particle number 1 (only for tests)
20523  ! omment if(ii.eq.5) then
20524  ! omment write(16,*) ' *****second half quasex'
20525  ! omment xkq2=sqrt(abs(kq2))
20526  ! omment xkql=xkq2*l*57.29578
20527  ! omment xks=sqrt(abs(ks2))
20528  ! omment xksl=xks*l**(1.5)*57.29578
20529  ! omment write(16,3300) ri,xkq2,xkql,xks,xksl
20530  ! omment call matrix
20531  ! omment endif
20532  ! ********END CONTROL
20533  call cobeam(ii, l)
20534  end do
20535  ! Test window after the second half quasex (only in transverse directions and phase)
20536  call cogetc
20537  ! Change the t.o.f of the reference
20538  tref = tref + xlqua/(2.*vref)
20539  call reject(ilost)
20540  ilost = ilost + nlost
20541  ! Reshuffles f(i,j) array after window (now done in 'reject')
20542  ! call shuffle
20543  dav1(idav, 36) = ngood
20544  write (16, *) 'TOF at output:', tref*fh*180./pi, ' deg'
20545  write (16, *) ' particles lost:', ilost
20546  ! returns coordinates to the initial orientation
20547  ! omment if(itwist.and.b.ne.0.) then
20548  ! omment qtwrad=-sqtwist
20549  ! omment call zrotat(qtwrad)
20550  ! omment endif
20551  if (iemgrw) call emiprt(0)
20552  call stapl(davtot*10.)
20553  return
20554  end subroutine qasex
20555  ! *******************************************************************
20556  ! SUBROUTINE ELQUA
20557  ! FIRST AND SECOND order TRANSPORT MATRIX R AND T
20558  ! PURE QUADRUPOLE FIELD, MATRIX R AND T ARE IN (M,RD)
20559  ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
20560  ! OTHERWIZE DECLARED *********
20561  ! *******************************************************************
20562  subroutine elqua
20563  implicit real *8(a-z)
20564  common /qsex/l, kq2, ks2
20565  common /bloc11/r(6, 6), t(6, 6, 6)
20566  common /secdr/iseor
20567  logical iseor
20568 
20569  akq2 = kq2*1.e04
20570  al = l*1.e-02
20571  akq = sqrt(abs(akq2))
20572  if (akq<1.e-13) akq = 1.e-13
20573  arg = akq*al
20574  csin = sin(arg)
20575  ccos = cos(arg)
20576  hsin = sinh(arg)
20577  hcos = cosh(arg)
20578  if (akq2>0.0) then
20579  ssok = csin/akq
20580  sc = ccos
20581  bsok = hsin/akq
20582  bc = hcos
20583  else
20584  ssok = hsin/akq
20585  sc = hcos
20586  bsok = csin/akq
20587  bc = ccos
20588  end if
20589  r(1, 1) = sc
20590  r(1, 2) = ssok
20591  r(2, 1) = -akq2*ssok
20592  r(2, 2) = sc
20593  r(3, 3) = bc
20594  r(3, 4) = bsok
20595  r(4, 3) = akq2*bsok
20596  r(4, 4) = bc
20597  if (.not. iseor) return
20598  ! T116=AMAT(12,1)
20599  t(1, 1, 6) = al*akq2*ssok/2.0
20600  ! T126=AMAT(17,1)
20601  t(1, 2, 6) = (ssok-al*sc)/2.0
20602  ! T216=AMAT(12,2)
20603  t(2, 1, 6) = akq2*(ssok+al*sc)/2.0
20604  ! T226=AMAT(17,2)
20605  t(2, 2, 6) = t(1, 1, 6)
20606  ! T336= AMAT(21,3) T346=AMAT(24,3)
20607  t(3, 3, 6) = -al*akq2*bsok/2.0
20608  t(3, 4, 6) = (bsok-al*bc)/2.0
20609  ! T436=AMAT(21,4) T446=AMAT(24,4)
20610  t(4, 3, 6) = -akq2*(bsok+al*bc)/2.0
20611  t(4, 4, 6) = t(3, 3, 6)
20612  ! T511=AMAT(7,5) T512=AMAT(8,5) T522=AMAT(13,5) T533=AMAT(18,5)
20613  t(5, 1, 1) = akq2*(al-sc*ssok)/4.0
20614  t(5, 1, 2) = -akq2*ssok*ssok/2.0
20615  t(5, 2, 2) = (al+sc*ssok)/4.0
20616  t(5, 3, 3) = -akq2*(al-bc*bsok)/4.0
20617  ! T534=AMAT(19,5) T544=AMAT(22,5)
20618  t(5, 3, 4) = akq2*(bsok*bsok)/2.0
20619  t(5, 4, 4) = (al+bc*bsok)/4.0
20620  return
20621  end subroutine elqua
20622  ! *******************************************************************
20623  ! SUBROUTINE ELSEX
20624  ! FIRST AND SECOND order TRANSPORT MATRIX R AND T
20625  ! PURE SEXTUPOLE FIELD, MATRIX R AND T ARE IN (M,RD)
20626  ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
20627  ! OTHERWIZE DECLARED *********
20628  ! *******************************************************************
20629  subroutine elsex
20630  implicit real *8(a-z)
20631  common /qsex/l, kq2, ks2
20632  common /bloc11/r(6, 6), t(6, 6, 6)
20633  common /secdr/iseor
20634  common /elq/inisk
20635  integer inisk
20636  logical iseor
20637 
20638  if (inisk==0) then
20639  aks2 = ks2*1.e06
20640  al = l*1.e-02
20641  else
20642  inisk = 0
20643  end if
20644  ! 1000 CONTINUE
20645  akl1 = aks2*al
20646  akl2 = akl1*al
20647  akl3 = akl2*al
20648  akl4 = akl3*al
20649  r(1, 2) = al
20650  r(3, 4) = al
20651  if (.not. iseor) return
20652  ! T522=AMAT(13,5) T544=AMAT(22,5)
20653  t(5, 2, 2) = al/2.0
20654  t(5, 4, 4) = al/2.0
20655  if (aks2==0.0) return
20656  ! T111=AMAT( 7,1) T112=AMAT( 8,1) T122=AMAT(13,1)
20657  t(1, 1, 1) = -akl2/2.0
20658  t(1, 1, 2) = -akl3/3.0
20659  t(1, 2, 2) = -akl4/12.0
20660  ! T133=AMAT(18,1) T134=AMAT(19,1) T144=AMAT(22,1)
20661  t(1, 3, 3) = akl2/2.0
20662  t(1, 3, 4) = akl3/3.0
20663  t(1, 4, 4) = akl4/12.0
20664  ! T211=AMAT( 7,2) T212=AMAT( 8,2) T222=AMAT(13,2)
20665  t(2, 1, 1) = -akl1
20666  t(2, 1, 2) = -akl2
20667  t(2, 2, 2) = -akl3/3.0
20668  ! T233=AMAT(18,2) T234=AMAT(19,2) T244=AMAT(22,2)
20669  t(2, 3, 3) = akl1
20670  t(2, 3, 4) = akl2
20671  t(2, 4, 4) = akl3/3.0
20672  ! T313=AMAT( 9,3) T314=AMAT( 10,3) T323=AMAT(14,3) T324=AMAT(15,3)
20673  t(3, 1, 3) = akl2
20674  t(3, 1, 4) = akl3/3.0
20675  t(3, 2, 3) = akl3/3.0
20676  t(3, 2, 4) = akl4/6.0
20677  ! T413=AMAT(9,4) T414=AMAT( 10,4) T423=AMAT(14,4) T424=AMAT(15,4)
20678  t(4, 1, 3) = akl1*2.0
20679  t(4, 1, 4) = akl2
20680  t(4, 2, 3) = akl2
20681  t(4, 2, 4) = akl3*2.0/3.0
20682  return
20683  end subroutine elsex
20684  ! *******************************************************************
20685  ! SUBROUTINE ELQSEX
20686  ! FIRST AND SECOND order TRANSPORT MATRIX R AND T
20687  ! QUADRUPOLE FIELD + SEXTUPOLE FIELD
20688  ! quadrupole field combined with a sextupole field
20689  ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
20690  ! OTHERWIZE DECLARED *********
20691  ! *******************************************************************
20692  subroutine elqsex
20693  implicit real *8(a-z)
20694  common /qsex/l, kq2, ks2
20695  common /bloc11/r(6, 6), t(6, 6, 6)
20696  common /secdr/iseor
20697  common /elq/inisk
20698  integer inisk
20699  logical iseor
20700 
20701  aks2 = ks2*1.e06
20702  al = l*1.e-02
20703  akq2 = kq2*1.e04
20704  akq = sqrt(abs(akq2))
20705  arg = akq*al
20706  csin = sin(arg)
20707  ccos = cos(arg)
20708  hsin = sinh(arg)
20709  hcos = cosh(arg)
20710  if (akq2>6.*0) then
20711  ssok = csin/akq
20712  sc = ccos
20713  bsok = hsin/akq
20714  bc = hcos
20715  else
20716  ssok = hsin/akq
20717  sc = hcos
20718  bsok = csin/akq
20719  bc = ccos
20720  end if
20721  if (akq2==6.*0) then
20722  r(1, 2) = al
20723  r(3, 4) = al
20724  else
20725  r(1, 1) = sc
20726  r(1, 2) = ssok
20727  r(2, 1) = -akq2*ssok
20728  r(2, 2) = sc
20729  r(3, 3) = bc
20730  r(3, 4) = bsok
20731  r(4, 3) = akq2*bsok
20732  r(4, 4) = bc
20733  end if
20734  if (.not. iseor) return
20735  ! omment IF(KS2.EQ.0.0)RETURN
20736  if (akq2==6.*0) then
20737  inisk = 1
20738  call elsex
20739  else
20740  ! T111=AMAT( 7,1) T112=AMAT( 8,1) T116=AMAT(12,1)
20741  t(1, 1, 1) = -aks2*(ssok*ssok+(1.0-sc)/akq2)/3.0
20742  t(1, 1, 2) = -2.0*aks2*(ssok*(1.0-sc)/akq2)/3.0
20743  t(1, 1, 6) = al*akq2*ssok/2.0
20744  ! T122=AMAT(13,1) T126=AMAT(17,1)
20745  t(1, 2, 2) = -aks2*(2.0*(1.0-sc)/akq2-ssok*ssok)/(3.0*akq2)
20746  t(1, 2, 6) = (ssok-al*sc)/2.0
20747  ! T133=AMAT(18,1) T134=AMAT(19,1) T144=AMAT(22,1)
20748  t(1, 3, 3) = aks2*(bsok*bsok+3.0*(1.0-sc)/akq2)/5.0
20749  t(1, 3, 4) = 2.0*aks2*(bsok*bc-ssok)/(5.0*akq2)
20750  t(1, 4, 4) = aks2*(bsok*bsok-2.0*(1.0-sc)/akq2)/(5.0*akq2)
20751  ! T211=AMAT( 7,2) T212= AMAT( 8,2) T216=AMAT(12,2)
20752  t(2, 1, 1) = -aks2*(2.0*ssok*sc+ssok)/3.0
20753  t(2, 1, 2) = -2.0*aks2*(sc*(1.0-sc)/akq2+ssok*ssok)/3.0
20754  t(2, 1, 6) = akq2*(ssok+al*sc)/2.0
20755  ! T222=AMAT(13,2) T226=AMAT(17,2)
20756  t(2, 2, 2) = -aks2*(2.0*ssok-2.0*ssok*sc)/(3.0*akq2)
20757  t(2, 2, 6) = t(1, 1, 6)
20758  ! T233=AMAT(18,2) T234=AMAT(19,2) T244=AMAT(22,2)
20759  t(2, 3, 3) = aks2*(2.0*bsok*bc+3.0*ssok)/5.0
20760  t(2, 3, 4) = 2.0*aks2*(bc*bc+bsok*bsok*akq2-sc)/(5.0*akq2)
20761  t(2, 4, 4) = 2.0*aks2*(bsok*bc-ssok)/(5.0*akq2)
20762  ! T313=AMAT(9,3) T314=AMAT(10,3) T323=AMAT(14,3)
20763  t(3, 1, 3) = 2.0*aks2*(bc*(1.0-sc)/akq2+2.0*ssok*bsok)/5.0
20764  t(3, 1, 4) = 2.0*aks2*(2.0*ssok*bc-bsok*(1.0+sc))/(5.0*akq2)
20765  t(3, 2, 3) = 2.0*aks2*(3.0*bsok-2.0*bsok*sc-ssok*bc)/(5.0*akq2)
20766  ! T324=AMAT(15,3) T336= AMAT(21,3) T346=AMAT(24,3)
20767  t(3, 2, 4) = 2.0*aks2*(2.0*bc*(1.0-sc)/akq2-ssok*bsok)/(5.0*akq2)
20768  t(3, 3, 6) = -al*akq2*bsok/2.0
20769  t(3, 4, 6) = (bsok-al*bc)/2.0
20770  ! T413=AMAT( 9,4) T414=AMAT(10,4) T423=AMAT(14,4) T424=AMAT(15,4)
20771  t(4, 1, 3) = 2.0*aks2*(bsok*(1.0-sc)+bc*ssok+2.0*sc*bsok+2.0*ssok*bc)/5.0
20772  t(4, 1, 4) = 2.0*aks2*(2.0*sc*bc+2.0*ssok*bsok*akq2-bc*(1.0+sc)+bsok*ssok*akq2)/(5.0*akq2)
20773  t(4, 2, 3) = 2.0*aks2*(3.0*bc-2.0*bc*sc+2.0*bsok*ssok*akq2-sc*bc-ssok*bsok*akq2)/(5.0*akq2)
20774  t(4, 2, 4) = 2.0*aks2*(2.0*bsok*(1.0-sc)+2.0*bc*ssok-sc*bsok-ssok*bc)/(5.0*akq2)
20775  ! T436=AMAT(21,4) T446=AMAT(24,4)
20776  t(4, 3, 6) = -akq2*(bsok+al*bc)/2.0
20777  t(4, 4, 6) = t(3, 3, 6)
20778  ! T511=AMAT(7,5) T512=AMAT(8,5) T522=AMAT(13,5) T533=AMAT(18,5)
20779  t(5, 1, 1) = akq2*(al-sc*ssok)/4.0
20780  t(5, 1, 2) = -akq2*ssok*ssok/2.0
20781  t(5, 2, 2) = (al+sc*ssok)/4.0
20782  t(5, 3, 3) = -akq2*(al-bc*bsok)/4.0
20783  ! T534=AMAT(19,5) T544=AMAT(22,5)
20784  t(5, 3, 4) = akq2*(bsok*bsok)/2.0
20785  t(5, 4, 4) = (al+bc*bsok)/4.0
20786  end if
20787  return
20788  end subroutine elqsex
20789  ! *******************************************************************
20790  ! SUBROUTINE solfield(bcret,intgr)
20791  ! Solenoid with an arbitrary magnetic field
20792  ! *******************************************************************
20793  subroutine solfield(bcret, intgr)
20794  implicit real *8(a-h, o-z)
20795  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20796  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
20797  common /fene/wdisp, wphas, wx, wy, rlim, ifw
20798  common /dyn/tref, vref
20799  common /rigid/boro
20800  common /dcspa/iesp
20801  common /faisc/f(10, iptsz), imax, ngood
20802  common /etcom/cog(8), exten(17), fd(iptsz)
20803  common /qmoyen/qmoy
20804  common /consta/vl, pi, xmat, rpel, qst
20805  common /tapes/in, ifile, meta
20806  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
20807  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
20808  common /shif/dtiph, shift
20809  common /rander/ialin
20810  common /femt/iemgrw, iemqesg
20811  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20812  common /compt/nrres, nrtre, nrbunc, nrdbun
20813  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
20814  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
20815  common /bloc11/r(6, 6), t(6, 6, 6)
20816  dimension rs(6, 6), rcul(6, 6)
20817  logical iesp, ichaes, shift, ialin, iemgrw
20818  character *1 cr
20819  ! print out on terminal of transport element # on one and the same line
20820  nrtre = nrtre + 1
20821  cr = char(13)
20822  write (6, 8254) nrtre, nrres, cr
20823 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
20824  ! read the magnetic field on the disk
20825  read (25, *) ncord
20826  if (ncord==0) then
20827  rewind(25)
20828  read (25, *) ncord
20829  end if
20830  crest = 0.
20831  do i = 1, ncord
20832  read (25, *) xspl(i), yspl(i)
20833  if (yspl(i)>crest) crest = yspl(i)
20834  end do
20835  zinf = xspl(1)
20836  zsup = xspl(ncord)
20837  call deriv2(ncord)
20838  npas = intgr
20839  dsol = (zsup-zinf)/float(npas)
20840  xlsol = (zsup-zinf)*100.
20841  write (16, 101) xlsol, crest, bcret
20842 101 format (5x, 'Field length =', f7.3, ' cm ', /, 5x, 'Crest of the field =', f10.4, ' kG', /5x, &
20843  'Attenuation factor =', f10.4, /)
20844  fh0 = fh/vl
20845  ! random errors in alignment
20846  if (ialin) call randali
20847  ! test window
20848  ilost = 0
20849  ! PLOT
20850  if (iprf==1) call stapl(davtot*10.)
20851  ! start prints in file 'short.data'
20852  idav = idav + 1
20853  iitem(idav) = 5
20854  dav1(idav, 1) = xlsol*10.
20855  dav1(idav, 2) = crest
20856  davti = davtot
20857  davtot = davtot + xlsol
20858  dav1(idav, 4) = davtot*10.
20859  zc = zinf
20860  iesp = .true.
20861  do ia = 1, 6
20862  do ib = 1, 6
20863  if (ia==ib) rcul(ia, ib) = 1.
20864  if (ia/=ib) rcul(ia, ib) = 0.
20865  end do
20866  end do
20867  bisol = 0.
20868  bisol2 = 0.
20869  fnpas = float(npas)
20870  do i = 1, npas
20871  zcf = zc + dsol
20872  zcf2 = zc + dsol/2.
20873  bsol = bcret*spline(ncord, zcf2)
20874  ! omment write(70,110) i,zcf2,bsol
20875  dscm = dsol*100.
20876  tref = tref + xlsol/(vref*fnpas)
20877  call fldsol(bsol, dscm)
20878  write (16, 520) i, zc, zcf, bsol
20879 520 format (2x, '**STEP: ', i2, ' LIMITS: inf(m)= ', f7.5, ' sup(m)= ', f7.5, ' AVERAGE FIELD(kG): ', e12.5)
20880  bisol = bisol + bsol*dsol
20881  bisol2 = bisol2 + bsol*bsol*dsol
20882  ! save equivalent transport matrix
20883  do ia = 1, 6
20884  do ib = 1, 6
20885  rs(ia, ib) = rcul(ia, ib)
20886  end do
20887  end do
20888  call mfordre(rcul, r, rs)
20889  ! ************TEST******************
20890  ! print first order matrix
20891  ! omment write(16,*) ' EQUIVALENT FIRST order MATRIX TRANSFORM (m-rad)'
20892  ! omment skl=0.5*acos(2.*r(1,1)-1.)*57.29578
20893  ! omment write(16,*) '**** K*LENGTH: ',skl,' degrees'
20894  ! omment DO IA=1,6
20895  ! omment write(16,100) (r(ia,ib),ib=1,6)
20896  ! omment ENDDO
20897  ! omment write(16,*) '*******cumul***************'
20898  ! omment DO IA=1,6
20899  ! omment write(16,100) (rcul(ia,ib),ib=1,6)
20900  ! omment ENDDO
20901  ! **********END TEST********************
20902  ! SPACE CHARGE
20903  if (.not. iesp) then
20904  iesp = .true.
20905  go to 720
20906  end if
20907  if (ichaes .and. xlsol>0.) then
20908  if (sce10==1 .or. sce10==3.) then
20909  dscm2 = dscm*2.
20910  call cesp(dscm2)
20911  iesp = .false.
20912  ! dispersion dE/E with respect to the C.O.G of the bunch
20913  call disp
20914  end if
20915  end if
20916 720 continue
20917  ! envelope sol
20918  write (16, *) 'distance', davti, dsol
20919  davti = davti + dsol*100.
20920  call stapl((davti)*10.)
20921  zc = zcf
20922  end do
20923  write (16, 922) zc, bisol, bisol2, bisol2/zc
20924 922 format (/, 'Field length (m): ', e12.5, /, 'Field integral (kG.m): ', e12.5, /, &
20925  'Field squared integral (kG**2.m): ', e12.5, /, 'Field squared integral/L (kG**2): ', e12.5, /)
20926  ! 110 format(2x,i5,2(2x,e12.5))
20927  ! print first order matrix
20928  write (16, *) ' EQUIVALENT FIRST order MATRIX TRANSFORM (m-rad)'
20929  skl = 0.5*acos(2.*rcul(1,1)-1.)*57.29578
20930  write (16, *) ' ******* K*LENGTH: ', skl, ' degrees'
20931  do ia = 1, 6
20932  write (16, 100)(rcul(ia,ib), ib=1, 6)
20933  end do
20934 100 format (6(3x,e12.5))
20935  ! **************************************************
20936  ! evolution of the t.o.f of the reference (moved inside loop - Alt)
20937  ! TREF=TREF+XLSOL/VREF
20938  dav1(idav, 36) = ngood
20939  ! plots
20940  call stapl(davtot*10.)
20941  if (iemgrw) call emiprt(0)
20942  write (16, *) 'particles lost in solenoid', ilost
20943  return
20944  end subroutine solfield
20945  ! *******************************************************************
20946  ! SUBROUTINE fldsol(dbs,step)
20947  ! solenoidal field
20948  ! *******************************************************************
20949  subroutine fldsol(dbs, step)
20950  implicit real *8(a-h, o-z)
20951  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
20952  common /faisc/f(10, iptsz), imax, ngood
20953  common /fene/wdisp, wphas, wx, wy, rlim, ifw
20954  common /consta/vl, pi, xmat, rpel, qst
20955  common /etcom/cog(8), exten(17), fd(iptsz)
20956  common /femt/iemgrw, iemqesg
20957  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
20958  common /sole/l, kl, ko
20959  real *8 l, kl, ko
20960 
20961  l = step
20962  b = dbs
20963  gpai = 0.
20964  do ii = 1, ngood
20965  gpai = gpai + f(7, ii)/xmat
20966  end do
20967  gpai = gpai/float(ngood)
20968  bpai = sqrt(1.-1./(gpai*gpai))
20969  xmco = xmat*bpai*gpai
20970  ri = 33.356*xmco*1.e-01/qst
20971  ko = b/ri
20972  if (ko==0.) ko = 1.e-16
20973  kl = ko*l
20974  ! half step
20975  ! omment kl=kl/2.
20976  call clear
20977  call elsol
20978  do ii = 1, ngood
20979  ! **********
20980  ! omment call clear
20981  ! omment gpai=f(7,ii)/xmat
20982  ! omment bpai=sqrt(1.-1./(gpai*gpai))
20983  ! omment xmco=xmat*bpai*gpai
20984  ! omment RI=33.356*XMCO*1.E-01/f(9,ii)
20985  ! omment KO = B /RI
20986  ! omment IF(KO .EQ. 0.) KO=1.E-16
20987  ! omment kl=ko*l
20988  ! omment call elsol
20989  ! ***************
20990  call cobeam(ii, l)
20991  ! evolution of the t.o.f has been made in the routine cobeam
20992  ! omment f(6,ii)=f(6,ii)+step/(bpai*vl)
20993  end do
20994  ! test window after the step (only in the transverse directions)
20995  call cogetc
20996  call reject(ilost)
20997  ! Reshuffles f(i,j) array after window (now done in 'reject')
20998  ! call shuffle
20999  return
21000  end subroutine fldsol
21001  ! *******************************************************************
21002  ! SUBROUTINE solnoid(imks,arg,xlsol)
21003  ! SOLENOID (fringe-fields are included in the transport matrix)
21004  ! space charge computations at the middle of the lens
21005  ! IMKS: IFLAG (see ARG)
21006  ! ARG: IMKS = 0 then ARG is K (cm-1), otherwise ARG is the
21007  ! field BSOL (kG)
21008  ! XLSOL : EFFECTIVE LENGHT (CM )
21009  ! *******************************************************************
21010  subroutine solnoid(imks, arg, xlsol)
21011  implicit real *8(a-h, o-z)
21012  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21013  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
21014  common /fene/wdisp, wphas, wx, wy, rlim, ifw
21015  common /dyn/tref, vref
21016  common /rigid/boro
21017  common /dcspa/iesp
21018  common /faisc/f(10, iptsz), imax, ngood
21019  common /etcom/cog(8), exten(17), fd(iptsz)
21020  common /qmoyen/qmoy
21021  common /consta/vl, pi, xmat, rpel, qst
21022  common /tapes/in, ifile, meta
21023  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
21024  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21025  common /shif/dtiph, shift
21026  common /rander/ialin
21027  common /femt/iemgrw, iemqesg
21028  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
21029  common /compt/nrres, nrtre, nrbunc, nrdbun
21030  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
21031  common /bloc11/r(6, 6), t(6, 6, 6)
21032  common /itvole/itvol, imamin
21033  common /tofev/ttvols
21034  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
21035  character *128 trace3h, trace3t, tif
21036  logical itvol, imamin
21037  ! dimension rs(6,6),rcul(6,6)
21038  logical iesp, ichaes, shift, ialin, iemgrw
21039  character *1 cr
21040  common /sole/l, kl, ko
21041  real *8 l, kl, ko
21042  ! print out on terminal of transport element # on one and the same line
21043  nrtre = nrtre + 1
21044  cr = char(13)
21045  ! print out on terminal of transport element # on one and the same line
21046  write (6, 8254) nrtre, nrres, cr
21047 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
21048  write (16, *) ' ****** SOLENOID *********'
21049  ! PLOT
21050  if (iprf==1) call stapl(davtot*10.)
21051  ilost = 0
21052  fh0 = fh/vl
21053  fcpi = fh*180./pi
21054  ! random errors in alignment
21055  if (ialin) call randali
21056  ! print out transport matrix (cog)
21057  gpa = 0.
21058  do ii = 1, ngood
21059  gpa = gpa + f(7, ii)/xmat
21060  end do
21061  gpa = gpa/float(ngood)
21062  l = xlsol
21063  bpa = sqrt(1.-1./(gpa*gpa))
21064  xmco = xmat*bpa*gpa
21065  ri = 33.356*xmco*1.e-01/qst
21066  if (imks/=0) then
21067  ! ARG is the field B (kG)
21068  b = arg
21069  ! KO = 2 * K (see ELSOL)
21070  ko = b/ri
21071  if (ko==0.) ko = 1.e-16
21072  else
21073  ! ARG is the strength K (cm-1)
21074  ! KO = 2 * K (see ELSOL)
21075  ko = 2.*arg
21076  if (ko==0.) ko = 1.e-16
21077  b = ko*ri
21078  end if
21079  kl = ko*l
21080  call clear
21081  call elsol
21082  xkql = (kl/2.)*57.29578
21083  ! trace3d
21084  kt3t = kt3t + 1
21085  write (tif, 6002) kt3t, kt3t, b*1000., 10.*xlsol
21086 6002 format (' nt(', i4, ')= 5, a(1,', i4, ')= ', f12.5, ' , ', f9.5)
21087  trace3t(kt3t) = tif
21088 
21089  write (16, 101) xlsol, b, ko/2., ri, xkql
21090 101 format (' LENGTH = ', f7.3, ' CM ', /, ' FIELD = ', f10.4, ' KG', /, ' K = ', e12.5, ' cm-1', /, &
21091  ' MOMENTUM = ', e12.5, ' kG.cm', /, ' TRANSVERSE COORDINATES ROTATION = ', e12.5, ' deg', /)
21092  call matrix
21093  write (16, 10) ttvols*fcpi, davtot
21094 10 format (' ** time of flight (input): ', e12.5, ' deg position: ', e12.5, ' cm')
21095  ! start prints in file 'short.data'
21096  idav = idav + 1
21097  iitem(idav) = 5
21098  dav1(idav, 1) = xlsol*10.
21099  dav1(idav, 2) = b
21100  dav1(idav, 3) = ko/2.
21101  davtot = davtot + xlsol
21102  dav1(idav, 4) = davtot*10.
21103  dav1(idav, 5) = ri
21104  ! first half solenoid
21105  dg = xlsol
21106  l = xlsol/2.
21107  do ii = 1, ngood
21108  call clear
21109  gpai = f(7, ii)/xmat
21110  bpai = sqrt(1.-1./(gpai*gpai))
21111  xmco = xmat*bpai*gpai
21112  ri = 33.356*xmco*1.e-01/f(9, ii)
21113  ko = b/ri
21114  if (ko==0.) ko = 1.e-16
21115  kl = ko*l
21116  call elsol
21117  call cobeam(ii, l)
21118  ! evolution of the t.o.f is made in routine cbeam
21119  ! omment f(6,ii)=f(6,ii)+l/(bpai*vl)
21120  end do
21121  ! space charge computations (only if l >0)
21122  if (ichaes .and. l>0.) then
21123  if (sce10==1 .or. sce10==3.) then
21124  iesp = .true.
21125  write (16, *) 'space charge at the middle '
21126  call cesp(xlsol)
21127  iesp = .false.
21128  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
21129  call disp
21130  end if
21131  end if
21132  ! test window after the first half solenoid
21133  call cogetc
21134  bcour = 0.
21135  do i = 1, ngood
21136  gpai = f(7, i)/xmat
21137  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
21138  end do
21139  bcour = bcour/float(ngood)
21140  gcour = 1./sqrt(1.-bcour*bcour)
21141  wcg = (gcour-1.)*xmat
21142  ! ----- window control
21143  tref = tref + xlsol/(vref*2.)
21144  call reject(ilost)
21145  ! Reshuffles f(i,j) array after window (now done in 'reject')
21146  ! call shuffle
21147  ! second half solenoid
21148  do ii = 1, ngood
21149  call clear
21150  gpai = f(7, ii)/xmat
21151  bpai = sqrt(1.-1./(gpai*gpai))
21152  xmco = xmat*bpai*gpai
21153  ri = 33.356*xmco*1.e-01/f(9, ii)
21154  ko = b/ri
21155  if (ko==0.) ko = 1.e-16
21156  kl = ko*l
21157  call elsol
21158  call cobeam(ii, l)
21159  end do
21160  ! t.o.f
21161  tref = tref + xlsol/(vref*2.)
21162  call reject(ilost)
21163  if (itvol) ttvols = tref
21164  tcog = 0.
21165  do i = 1, ngood
21166  tcog = tcog + f(6, i)
21167  end do
21168  tcog = tcog/float(ngood)
21169  if (itvol) then
21170  write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
21171 11 format (' ** tof for adjustments: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
21172  'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
21173  else
21174  write (16, 12) tref*fcpi, tcog*fcpi
21175 12 format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
21176  end if
21177  dav1(idav, 36) = ngood
21178  ! plots
21179  call stapl(davtot*10.)
21180  if (iemgrw) call emiprt(0)
21181  write (16, *) 'particles lost in solenoid', ilost
21182  return
21183  end subroutine solnoid
21184  ! *******************************************************************
21185  ! SUBROUTINE elsol
21186  ! first order and second order R and T solenoid matrix
21187  ! *******************************************************************
21188  subroutine elsol
21189  implicit real *8(a-h, o-z)
21190  common /sole/l, kl, ko
21191  common /rigid/boro
21192  real *8 l, kl, ko
21193  common /bloc11/r(6, 6), t(6, 6, 6)
21194  common /secdr/iseor
21195  logical iseor
21196  ! PURE SOLENOID FIELD, MATRIX R AND T ARE IN (M,RD)
21197  ! SAVE KO AND L
21198  sako = ko
21199  sal = l
21200  ! convert (cm,rd) ==> (m,rd)
21201  ko = ko*100.
21202  l = l*1.e-02
21203  sn = sin(kl)
21204  cs = cos(kl)
21205  r(4, 4) = 0.5 + 0.5*cs
21206  r(3, 3) = r(4, 4)
21207  r(2, 2) = r(4, 4)
21208  r(1, 1) = r(4, 4)
21209  r(1, 4) = (1.-cs)/ko
21210  r(3, 2) = -r(1, 4)
21211  r(4, 1) = 0.25*ko*(1.-cs)
21212  r(2, 3) = -r(4, 1)
21213  r(4, 2) = -0.5*sn
21214  r(3, 1) = r(4, 2)
21215  r(2, 4) = -r(3, 1)
21216  r(1, 3) = r(2, 4)
21217  r(3, 4) = r(1, 3)*2./ko
21218  r(1, 2) = r(3, 4)
21219  r(4, 3) = -0.25*ko*sn
21220  r(2, 1) = r(4, 3)
21221  ! see element 16; 3. in TRANSPORT USER MANUAL for SM (here: SM=0)
21222  ! omment R(5,6) = R(5,6) + L * SM**2/(RI**2 + SM**2)
21223  if (.not. iseor) go to 200
21224  temp = 0.5*ko*l*sn
21225  t(1, 1, 6) = temp
21226  t(2, 2, 6) = temp
21227  t(3, 3, 6) = temp
21228  t(4, 4, 6) = temp
21229  t(1, 2, 6) = sn/ko - l*cs
21230  t(3, 4, 6) = t(1, 2, 6)
21231  temp = -0.5*ko*l*cs
21232  t(1, 3, 6) = temp
21233  t(2, 4, 6) = temp
21234  t(4, 2, 6) = -temp
21235  t(3, 1, 6) = -temp
21236  t(1, 4, 6) = (1.0-cs)/ko - l*sn
21237  t(3, 2, 6) = -t(1, 4, 6)
21238  t(2, 1, 6) = 0.25*ko*(ko*l*cs+sn)
21239  t(4, 3, 6) = t(2, 1, 6)
21240  t(2, 3, 6) = 0.25*ko*(1.0-cs+ko*l*sn)
21241  t(4, 1, 6) = -t(2, 3, 6)
21242  t(5, 2, 2) = 0.5*l
21243  t(5, 4, 4) = 0.5*l
21244 200 continue
21245  ! RESTORE KO AND L
21246  ko = sako
21247  l = sal
21248 
21249  ! PATH LENGTH TERMS
21250  ! see element 16; 3. in TRANSPORT USER MANUAL for SM here one takes: SM=0
21251  ! omment T(5,6,6) = T(5,6,6) - L*(SM**2 + 1.5*RI**2)*SM**2/
21252  ! omment 1 (SM**2 + RI**2)**2
21253  ! omment T(5,5,6) = SM**2/(SM**2 + RI**2)
21254  return
21255  end subroutine elsol
21256  ! *******************************************************************
21257  ! SUBROUTINE mfordre(rc,ra,rb)
21258  ! Calculates RC=RA*RB
21259  ! *******************************************************************
21260  subroutine mfordre(rc, ra, rb)
21261  implicit real *8(a-h, o-z)
21262  dimension ra(6, 6), rb(6, 6), rc(6, 6)
21263 
21264  do i1 = 1, 6
21265  do i2 = 1, 6
21266  ghost = 0.0
21267  do i3 = 1, 6
21268  ghost = ghost + ra(i1, i3)*rb(i3, i2)
21269  end do
21270  rc(i1, i2) = ghost
21271  end do
21272  end do
21273  return
21274  end subroutine mfordre
21275  ! *******************************************************************
21276  ! SUBROUTINE solquad(iksq,args,argq,xlsol,rg)
21277  ! SOLENOID FIELD ASSOCIATED WITH QUADRUPOLE FIELD
21278  ! space charge computations at the middle of the lens
21279  ! --IKSQ: IFLAG
21280  ! --ARGS: STRENGTH or FIELD OF SOLENOID
21281  ! If IKSQ = 0 then ARGS is the STRENGTH (cm-1), otherwise ARGS
21282  ! is the FIELD (kG)
21283  ! --ARGQ: STRENGTH or FIELD of QUADRUPOLE
21284  ! If IKSQ = 0 then ARGQ is the STRENGTH (cm-2), otherwise ARGQ
21285  ! is the FIELD (kG)
21286  ! SIGN CONVENTIONS:
21287  ! SOLENOID: ARGS positive = rotate the transverse coordinates
21288  ! about the z-axis in the clockwise direction.
21289  ! QUADRUPOLE: ARGQ positive = focusing in the plane (x,z)
21290  ! --XLSOL : EFFECTIVE LENGHT OF THE LENS(cm)
21291  ! --RG : APERTURE RADIUS OF THE LENS (cm)
21292  ! *******************************************************************
21293  subroutine solquad(iksq, args, argq, xlsol, rg)
21294  implicit real *8(a-h, o-z)
21295  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21296  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
21297  common /fene/wdisp, wphas, wx, wy, rlim, ifw
21298  common /dyn/tref, vref
21299  common /rigid/boro
21300  common /dcspa/iesp
21301  common /faisc/f(10, iptsz), imax, ngood
21302  common /etcom/cog(8), exten(17), fd(iptsz)
21303  common /qmoyen/qmoy
21304  common /consta/vl, pi, xmat, rpel, qst
21305  common /tapes/in, ifile, meta
21306  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
21307  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21308  common /shif/dtiph, shift
21309  common /rander/ialin
21310  common /femt/iemgrw, iemqesg
21311  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
21312  common /compt/nrres, nrtre, nrbunc, nrdbun
21313  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
21314  logical ichaes
21315  logical iesp, shift, ialin, iemgrw
21316  character *1 cr
21317  common /slq/l, kso, kqo
21318  real *8 l, kso, kqo
21319  ! print out on terminal of transport element # on one and the same line
21320  nrtre = nrtre + 1
21321  cr = char(13)
21322  write (6, 8254) nrtre, nrres, cr
21323 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
21324  fh0 = fh/vl
21325  ! PLOT
21326  if (iprf==1) call stapl(davtot*10.)
21327  ! random errors in alignment
21328  if (ialin) call randali
21329  ilost = 0
21330  ! magnetic rigidity (cog)
21331  gpa = 0.
21332  do ii = 1, ngood
21333  gpa = gpa + f(7, ii)/xmat
21334  end do
21335  gpa = gpa/float(ngood)
21336  l = xlsol
21337  bpa = sqrt(1.-1./(gpa*gpa))
21338  xmco = xmat*bpa*gpa
21339  ri = 33.356*xmco*1.e-01/qst
21340  if (iksq/=0) then
21341  ! argq: quadrupole field (kG), args:solenoid field:(kG)
21342  ! quadrupole
21343  fq = argq
21344  bq = fq/rg
21345  kqo = bq/ri
21346  strq = kqo
21347  ! solenoid (KSO = 2 * K, see ELSQ)
21348  bs = args
21349  kso = bs/ri
21350  strs = kso/2
21351  else
21352  ! argq: quadupole strength (cm-2), args: solenoid strength (cm-1)
21353  ! quadrupole
21354  kqo = argq
21355  strq = argq
21356  bq = argq*ri
21357  fq = bq*rg
21358  ! solenoid (KSO = 2 * K, see ELSQ)
21359  strs = args
21360  bs = 2.*strs*ri
21361  kso = bs/ri
21362  end if
21363  xks = kso/2.
21364  xksl = xks*l*57.29578
21365  write (16, *) '****SOLENOID+QUADRUPOLE*******'
21366  write (16, 101) xlsol, rg, bs, strs, xksl, fq, strq, ri
21367 101 format (' LENGTH =', f7.3, ' cm APERTURE RADIUS=', e12.5, ' cm', /, ' SOLENOID: FIELD = ', f10.4, ' kG K = ', &
21368  e12.5, ' cm-1 ROTATING ANGLE = ', e12.5, ' deg', /, ' QUADRUPOLE: FIELD =', f10.4, ' kG K2 =', e12.5, &
21369  ' cm-2 ', /, ' RIGIDITY = ', e12.5, ' kG.cm', /)
21370  ! print transport matrix (c.o.g.)
21371  ! For convenience, the matrix R and T are computed for a positive KQO = (B/r)*(1/BRO)
21372  ! if KQO is negative one has seting up 90 degree rotation on the beam
21373  call elsq
21374  write (16, *) ' The matrix R and T are shown for a positive strength'
21375  write (16, *) ' For a negative strength set up 90 deg rotation on the beam'
21376  call matrix
21377  ! start prints in file 'short.data'
21378  idav = idav + 1
21379  iitem(idav) = 11
21380  dav1(idav, 1) = xlsol*10.
21381  dav1(idav, 2) = bs
21382  dav1(idav, 3) = fq
21383  dav1(idav, 5) = strq
21384  dav1(idav, 6) = kso/2.
21385  dav1(idav, 7) = rg*10.
21386  dav1(idav, 8) = ri
21387  davtot = davtot + xlsol
21388  dav1(idav, 4) = davtot*10.
21389  ! first half lens
21390  dg = xlsol
21391  l = xlsol/2.
21392  do ii = 1, ngood
21393  call clear
21394  gpai = f(7, ii)/xmat
21395  bpai = sqrt(1.-1./(gpai*gpai))
21396  xmco = xmat*bpai*gpai
21397  ri = 33.356*xmco*1.e-01/f(9, ii)
21398  ! KSO =K/2, see ELSQ
21399  kso = bs/ri
21400  if (kso==6.*0) kso = 1.e-16
21401  kqo = bq/ri
21402  call elsq
21403  ! the matrix R and T are computed for a positive KQO = (B/rg)*(1/BRO)
21404  ! if KQO is negative set up 90 degree rotation on the beam
21405  if (kqo<6.*0) then
21406  irot = ii
21407  call rotat(irot)
21408  call cobeam(ii, l)
21409  ! return the coordinates to their initial orientation
21410  irot = -ii
21411  call rotat(irot)
21412  else
21413  call cobeam(ii, l)
21414  end if
21415  end do
21416  ! Charge space effect (if l >0)
21417  if (ichaes .and. l>0.) then
21418  if (sce10==1 .or. sce10==3.) then
21419  iesp = .true.
21420  write (16, *) 'space charge at the middle '
21421  call cesp(xlsol)
21422  iesp = .false.
21423  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
21424  call disp
21425  end if
21426  end if
21427  ! test window after the first half solquad
21428  call cogetc
21429  bcour = 0.
21430  do i = 1, ngood
21431  gpai = f(7, i)/xmat
21432  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
21433  end do
21434  bcour = bcour/float(ngood)
21435  gcour = 1./sqrt(1.-bcour*bcour)
21436  wcg = (gcour-1.)*xmat
21437  ! ----- convert wdisp in dp/p (for window control)
21438  tref = tref + xlsol/(2.*vref)
21439  call reject(ilost)
21440  ! Reshuffles f(i,j) array after window (now done in 'reject')
21441  ! call shuffle
21442  ! beam after the second half lens
21443  do ii = 1, ngood
21444  call clear
21445  gpai = f(7, ii)/xmat
21446  bpai = sqrt(1.-1./(gpai*gpai))
21447  xmco = xmat*bpai*gpai
21448  ri = 33.356*xmco*1.e-01/f(9, ii)
21449  kso = bs/ri
21450  ! KSO =K/2, see ELSQ
21451  if (kso==0.) kso = 1.e-16
21452  kqo = bq/ri
21453  call elsq
21454  ! the matrix R and T are computed for a positive KQO = (B/r)*(1/BRO)
21455  ! if KQO is negative set up 90 degree rotation on the beam
21456  if (kqo<6.*0) then
21457  irot = ii
21458  call rotat(irot)
21459  call cobeam(ii, l)
21460  irot = -ii
21461  call rotat(irot)
21462  else
21463  call cobeam(ii, l)
21464  end if
21465  end do
21466  ! t.o.f of reference
21467  tref = tref + xlsol/(vref*2.)
21468  call reject(ilost)
21469  dav1(idav, 36) = ngood
21470  ! plots
21471  call stapl(davtot*10.)
21472  if (iemgrw) call emiprt(0)
21473  write (16, *) 'particles lost in solenoid', ilost
21474  return
21475  end subroutine solquad
21476  ! *******************************************************************
21477  ! SUBROUTINE rotat(ii)
21478  ! (+-) 90 DEG BEAM ROTATION
21479  ! *******************************************************************
21480  subroutine rotat(ii)
21481  implicit real *8(a-h, o-z)
21482  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21483  common /faisc/f(10, iptsz), imax, ngood
21484  dimension ff(6)
21485 
21486  if (ii>=0) then
21487  ! 90 degree rotation
21488  ff(1) = f(2, ii)
21489  ff(2) = f(3, ii)
21490  ff(3) = f(4, ii)
21491  ff(4) = f(5, ii)
21492  f(2, ii) = ff(3)
21493  f(3, ii) = ff(4)
21494  f(4, ii) = -ff(1)
21495  f(5, ii) = -ff(2)
21496  else
21497  ! -90 degree rotation
21498  ii = -ii
21499  ff(1) = f(2, ii)
21500  ff(2) = f(3, ii)
21501  ff(3) = f(4, ii)
21502  ff(4) = f(5, ii)
21503  f(2, ii) = -ff(3)
21504  f(3, ii) = -ff(4)
21505  f(4, ii) = ff(1)
21506  f(5, ii) = ff(2)
21507  end if
21508  return
21509  end subroutine rotat
21510  ! *******************************************************************
21511  ! SUBROUTINE elsq
21512  ! FIRST AND SECOND order MATRIX R AND T (m,rd)
21513  ! quadrupole field combined with a solenoid field
21514  ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
21515  ! OTHERWIZE DECLARED *********
21516  ! *******************************************************************
21517  subroutine elsq
21518  implicit real *8(a-z)
21519  common /rigid/boro
21520  common /slq/l, kso, kqo
21521  common /bloc11/r(6, 6), t(6, 6, 6)
21522  common /secdr/iseor
21523  logical iseor
21524 
21525  al = l*1.e-02
21526  akq = kqo*1.e04
21527  aks = kso*1.e02
21528  aks = aks/2.
21529  akq4 = akq*akq
21530  aks2 = aks*aks
21531  aks3 = aks2*aks
21532  aks4 = aks2*aks2
21533  q2 = dsqrt(akq4+4.0*aks4)
21534  q2i = 1.0/q2
21535  sk1 = sqrt(2.0*aks2+q2)
21536  sk3 = sqrt(abs(q2-2.0*aks2))
21537  ss = sin(sk1*al)
21538  sc = cos(sk1*al)
21539  bs = sinh(sk3*al)
21540  bc = cosh(sk3*al)
21541  skp = 0.5*(sk1+sk3)
21542  skm = 0.5*(sk1-sk3)
21543  skp2 = skp*skp
21544  skp3 = skp2*skp
21545  skm2 = skm*skm
21546  skm3 = skm2*skm
21547  r(1, 1) = q2i*(skp2*sc+skm2*bc)
21548  r(1, 2) = q2i*(skp*ss-skm*bs)
21549  r(1, 3) = q2i*aks*(skm*ss+skp*bs)
21550  r(1, 4) = q2i*aks*(bc-sc)
21551  r(2, 1) = q2i*(-skp3*ss-skm3*bs)
21552  r(2, 2) = q2i*(skp2*sc+skm2*bc)
21553  r(2, 3) = q2i*aks3*(sc-bc)
21554  r(2, 4) = q2i*aks*(skp*ss-skm*bs)
21555  r(3, 1) = q2i*aks*(skm*bs-skp*ss)
21556  r(3, 2) = q2i*aks*(sc-bc)
21557  r(3, 3) = q2i*(skm2*sc+skp2*bc)
21558  r(3, 4) = q2i*(skm*ss+skp*bs)
21559  r(4, 1) = q2i*aks3*(bc-sc)
21560  r(4, 2) = q2i*aks*(-skm*ss-skp*bs)
21561  r(4, 3) = q2i*(skp3*bs-skm3*ss)
21562  r(4, 4) = q2i*(skm2*sc+skp2*bc)
21563  if (.not. iseor) return
21564  daks = -aks
21565  dakq = -akq
21566  dakq4 = 2.0*akq*dakq
21567  daks2 = 2.0*aks*daks
21568  daks3 = 3.0*aks2*daks
21569  daks4 = 4.0*aks3*daks
21570  dq2 = 0.5*q2i*(dakq4+4.0*daks4)
21571  q2i2 = q2i*q2i
21572  dq2i = -q2i2*dq2
21573  dsk1 = (2.0*daks2+dq2)/(2.0*sk1)
21574  dsk3 = 0.0
21575  if (sk3/=6.*0) dsk3 = (dq2-2.0*daks2)/(2.0*sk3)
21576  dss = sc*dsk1*al
21577  dsc = -ss*dsk1*al
21578  dbs = bc*dsk3*al
21579  dbc = bs*dsk3*al
21580  dskp = 0.5*(dsk1+dsk3)
21581  dskm = 0.5*(dsk1-dsk3)
21582  dskp2 = 2.0*skp*dskp
21583  dskp3 = 3.0*skp2*dskp
21584  dskm2 = 2.0*skm*dskm
21585  dskm3 = 3.0*skm2*dskm
21586  t(1, 1, 6) = dq2i*(skp2*sc+skm2*bc) + q2i*(dskp2*sc+skp2*dsc+dskm2*bc+skm2*dbc)
21587  t(1, 2, 6) = dq2i*(skp*ss-skm*bs) + q2i*(dskp*ss+skp*dss-dskm*bs-skm*dbs)
21588  t(1, 3, 6) = (dq2i*aks+q2i*daks)*(skm*ss+skp*bs) + q2i*aks*(dskm*ss+skm*dss+dskp*bs+skp*dbs)
21589  t(1, 4, 6) = (dq2i*aks+q2i*daks)*(bc-sc) + q2i*aks*(dbc-dsc)
21590  t(2, 1, 6) = dq2i*(-skp3*ss-skm3*bs) + q2i*(-dskp3*ss-skp3*dss-dskm3*bs-skm3*dbs)
21591  t(2, 2, 6) = t(1, 1, 6)
21592  t(2, 3, 6) = (dq2i*aks3+q2i*daks3)*(sc-bc) + q2i*aks3*(dsc-dbc)
21593  t(2, 4, 6) = (dq2i*aks+q2i*daks)*(skp*ss-skm*bs) + q2i*aks*(dskp*ss+skp*dss-dskm*bs-skm*dbs)
21594  t(3, 1, 6) = -t(2, 4, 6)
21595  t(3, 2, 6) = -t(1, 4, 6)
21596  t(3, 3, 6) = dq2i*(skm2*sc+skp2*bc) + q2i*(dskm2*sc+skm2*dsc+dskp2*bc+skp2*dbc)
21597  t(3, 4, 6) = dq2i*(skm*ss+skp*bs) + q2i*(dskm*ss+skm*dss+dskp*bs+skp*dbs)
21598  t(4, 1, 6) = -t(2, 3, 6)
21599  ! omment AMAT(17,4,MATADR)=-AMAT(21,1,MATADR)
21600  t(4, 2, 6) = -t(1, 3, 6)
21601  t(4, 3, 6) = dq2i*(skp3*bs-skm3*ss) + q2i*(dskp3*bs+skp3*dbs-dskm3*ss-skm3*dss)
21602  t(4, 4, 6) = t(3, 3, 6)
21603  aisssc = 0.0
21604  if (sk1/=0.0) aisssc = ss*ss/(2.0*sk1)
21605  aibsbc = 0.0
21606  if (sk3/=0.0) aibsbc = bs*bs/(2.0*sk3)
21607  aissbc = q2i*(sk3*ss*bs-sk1*sc*bc+sk1)
21608  aiscbs = q2i*(sk3*sc*bc+sk1*ss*bs-sk3)
21609  aiss2 = 0.0
21610  aisc2 = al
21611  aibs2 = 0.0
21612  aibc2 = al
21613  if (sk1/=0.0) aiss2 = 0.5*(al-ss*sc/sk1)
21614  if (sk1/=0.0) aisc2 = 0.5*(al+ss*sc/sk1)
21615  if (sk3/=0.0) aibs2 = 0.5*(bs*bc/sk3-al)
21616  if (sk3/=0.0) aibc2 = 0.5*(al+bs*bc/sk3)
21617  aissbs = q2i*(sk3*ss*bc-sk1*sc*bs)
21618  aiscbc = q2i*(sk1*ss*bc+sk3*sc*bs)
21619  aks5 = aks4*aks
21620  aks6 = aks5*aks
21621  skp4 = skp3*skp
21622  skp5 = skp4*skp
21623  skp6 = skp5*skp
21624  skm4 = skm3*skm
21625  skm5 = skm4*skm
21626  skm6 = skm5*skm
21627  q4i = q2i*q2i
21628  t(5, 1, 1) = q4i*0.5*(skp6*aiss2+skm6*aibs2-2.0*skp3*skm3*aissbs+aks6*(aisc2+aibc2-2.0*aiscbc))
21629  t(5, 1, 2) = q4i*(-skp5*aisssc-skp3*skm2*aissbc-skm3*skp2*aiscbs-skm5*aibsbc-aks4*(-skm*aisssc-skp*aiscbs+skm* &
21630  aissbc+skp*aibsbc))
21631  t(5, 1, 3) = q4i*aks3*((skp3-skm3)*(aissbc-aisssc)+(skp3+skm3)*(aibsbc-aiscbs))
21632  t(5, 1, 4) = q4i*(aks*(-skp4*aiss2-(skp3*skm+skm3*skp)*aissbs+skm4*aibs2)+aks3*(-skm2*aisc2-(skp2-skm2)*aiscbc+ &
21633  skp2*aibc2))
21634  t(5, 2, 2) = q4i*0.5*(skp4*aisc2+2.0*skp2*skm2*aiscbc+skm4*aibc2+aks2*(skm2*aiss2+2.0*skp*skm*aissbs+skp2*aibs2))
21635  t(5, 2, 3) = q4i*(aks3*(skp2*aisc2-(skp2-skm2)*aiscbc-skm2*aibc2)-aks*(-skm4*aiss2+(skm*skp3- &
21636  skp*skm3)*aissbs+skp4*aibs2))
21637  t(5, 2, 4) = q4i*aks*((skp3-skm3)*aisssc-(skp2*skm+skp*skm2)*aiscbs+(skm2*skp-skm*skp2)*aissbc-(skm3+skp3)*aibsbc)
21638  t(5, 3, 3) = q4i*0.5*(aks6*(aisc2-2.0*aiscbc+aibc2)+skm6*aiss2-2.0*skm3*skp3*aissbs+skp6*aibs2)
21639  t(5, 3, 4) = q4i*(aks4*(skp*aisssc-skm*aiscbs-skp*aissbc+skm*aibsbc)-skm5*aisssc-skm3*skp2*aissbc+skp3*skm2*aiscbs &
21640  +skp5*aibsbc)
21641  t(5, 4, 4) = q4i*0.5*(aks2*(skp2*aiss2-2.0*skp*skm*aissbs+skm2*aibs2)+skm4*aisc2+2.0*skm2*skp2*aiscbc+skp4*aibc2)
21642  return
21643  end subroutine elsq
21644  ! *******************************************************************
21645  ! SUBROUTINE fdrift(xl,npart,imit)
21646  ! DIVIDE A DRIFT LENGHT OF :XL CM IN :NPART PARTIAL DRIFTS
21647  ! This will allow several space charge computations in the drift
21648  ! *******************************************************************
21649  subroutine fdrift(xl, npart, imit)
21650  implicit real *8(a-h, o-z)
21651 
21652  dl = xl/float(npart)
21653  do i = 1, npart
21654  call drift(dl)
21655  if (imit/=0.) call emiprt(0)
21656  end do
21657  return
21658  end subroutine fdrift
21659  ! *******************************************************************
21660  ! SUBROUTINE drift(dl)
21661  ! DRIFT LENGHT
21662  ! space charge computation at the middle of the drift
21663  ! *******************************************************************
21664  subroutine drift(dl)
21665  implicit real *8(a-h, o-z)
21666  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21667  common /rigid/boro
21668  common /consta/vl, pi, xmat, rpel, qst
21669  common /dyn/tref, vref
21670  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
21671  common /faisc/f(10, iptsz), imax, ngood
21672  common /tapes/in, ifile, meta
21673  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21674  common /etcom/cog(8), exten(17), fd(iptsz)
21675  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
21676  common /fene/wdisp, wphas, wx, wy, rlim, ifw
21677  common /dcspa/iesp
21678  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
21679  common /shif/dtiph, shift
21680  common /femt/iemgrw, iemqesg
21681  common /posc/xpsc
21682  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
21683  common /tofev/ttvols
21684  common /itvole/itvol, imamin
21685  logical iesp, ichaes, shift, iemgrw, itvol, imamin
21686 
21687  ilost = 0
21688  fh0 = fh/vl
21689  fcpi = fh*180./pi
21690  write (16, *) '*** DRIFT of length ', dl, ' cm'
21691  if (itvol) write (16, 10) ttvols*fcpi, davtot
21692 10 format (' ** tof for adjustments at input: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice')
21693  ! STATISTICS
21694  if (iprf==1) call stapl(davtot*10.)
21695  ! random error in position only if dl is positif
21696  ! Beam at the half drift
21697  dg2 = dl/2.
21698  do i = 1, ngood
21699  ! conversion mrad ===> rad
21700  f2 = f(3, i)*.001
21701  f4 = f(5, i)*.001
21702  f(2, i) = f(2, i) + dg2*tan(f2)
21703  f(4, i) = f(4, i) + dg2*tan(f4)/cos(f2)
21704  gpai = f(7, i)/xmat
21705  bpai = sqrt(1.-1./(gpai*gpai))
21706  vpai = vl*bpai
21707  f(6, i) = f(6, i) + dg2/(vpai*cos(f2)*cos(f4))
21708  end do
21709  ! ENVEL
21710  ! start prints in file 'short.data'
21711  davtot = davtot + dl
21712  if (dl>0.) then
21713  ! nlength=nlength+1
21714  idav = idav + 1
21715  iitem(idav) = 7
21716  dav1(idav, 1) = dl*10.
21717  dav1(idav, 4) = davtot*10.
21718  end if
21719  ! Charge space (if dl >1.e-04)
21720  if (ichaes .and. dl>=1.e-04) then
21721  if (sce10==3.) then
21722  iesp = .true.
21723  write (16, *) ' space charge at the middle'
21724  call cesp(dl)
21725  iesp = .false.
21726  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
21727  call disp
21728  end if
21729  end if
21730  ! Test window after the first half drift
21731  tref = tref + dl/(vref*2.)
21732  call reject(ilost)
21733  ! Reshuffles f(i,j) array after window (now done in 'reject')
21734  ! call shuffle
21735  il = ilost
21736  ! Beam for the second half drift
21737  do i = 1, ngood
21738  f2 = f(3, i)*.001
21739  f4 = f(5, i)*.001
21740  f(2, i) = f(2, i) + dg2*tan(f2)
21741  f(4, i) = f(4, i) + dg2*tan(f4)/cos(f2)
21742  gpai = f(7, i)/xmat
21743  bpai = sqrt(1.-1./(gpai*gpai))
21744  vpai = vl*bpai
21745  f(6, i) = f(6, i) + dg2/(vpai*cos(f2)*cos(f4))
21746  end do
21747  ! Test window after the second half drift (only in transverse directions and phase)
21748  tref = tref + dl/(vref*2.)
21749  call reject(ilost)
21750  il = il + ilost
21751  ! change the reference and the TOF
21752  if (itvol) ttvols = tref
21753  if (dl>0.) then
21754  dav1(idav, 36) = ngood
21755  ! envelope
21756  call stapl(davtot*10.)
21757  end if
21758  tcog = 0.
21759  do i = 1, ngood
21760  tcog = tcog + f(6, i)
21761  end do
21762  tcog = tcog/float(ngood)
21763  if (itvol) then
21764  write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
21765 11 format (' ** tof for adjustments : ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
21766  'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
21767  else
21768  write (16, 12) tref*fcpi, tcog*fcpi
21769 12 format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
21770  end if
21771  write (16, *) 'particles lost in drift: ', il
21772  if (iemgrw .and. dl>0.) then
21773  if (iemqesg==2) call emiprt(0)
21774  end if
21775  return
21776  end subroutine drift
21777  subroutine clear
21778  ! CLEAR MATRIX R AND T
21779  implicit real *8(a-h, o-z)
21780  common /bloc11/r(6, 6), t(6, 6, 6)
21781  common /secdr/iseor
21782  logical iseor
21783  ! CLEAR R
21784  do ia = 1, 6
21785  do ib = 1, 6
21786  r(ia, ib) = 0.
21787  if (ia==ib) r(ia, ib) = 1.
21788  end do
21789  end do
21790  ! CLEAR T
21791  if (iseor) then
21792  do ia = 1, 6
21793  do ib = 1, 6
21794  do ic = 1, 6
21795  t(ia, ib, ic) = 0.
21796  end do
21797  end do
21798  end do
21799  end if
21800  return
21801  end subroutine clear
21802  ! *******************************************************************
21803  ! SUBROUTINE cobeam(ii,xl)
21804  ! MATRIX BASED BEAM COMPUTATION
21805  ! *******************************************************************
21806  subroutine cobeam(ii, xl)
21807  implicit real *8(a-h, o-z)
21808  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21809  common /faisc/f(10, iptsz), imax, ngood
21810  common /bloc11/r(6, 6), t(6, 6, 6)
21811  common /etcom/cog(8), exten(17), fd(iptsz)
21812  common /consta/vl, pi, xmat, rpel, qst
21813  common /radia/trt, rmoy, xintf, crae
21814  common /secdr/iseor
21815  logical iseor
21816  dimension sf(6), ssf(6)
21817  ! MATRIX R AND T ARE IN M-RD
21818  ! beam conversion: CM ===> M MRD ==> RD
21819  sf(1) = f(2, ii)*1.e-02
21820  sf(2) = f(3, ii)*1.e-03
21821  sf(3) = f(4, ii)*1.e-02
21822  sf(4) = f(5, ii)*1.e-03
21823  sf(5) = xl*1.e-02
21824  sf(5) = sf(5)/(cos(sf(2))*cos(sf(4)))
21825  sf(6) = (fd(ii)-1.)
21826  ! FIRST order COMPUTATION (M-RD)
21827  do ia = 1, 6
21828  ssf(ia) = 0.
21829  do ib = 1, 6
21830  ssf(ia) = r(ia, ib)*sf(ib) + ssf(ia)
21831  end do
21832  end do
21833  if (.not. iseor) go to 10
21834  ! SECOND order COMPUTATION (M-RD)
21835  do ia = 1, 6
21836  do ib = 1, 6
21837  do ic = 1, 6
21838  ssf(ia) = ssf(ia) + t(ia, ib, ic)*sf(ib)*sf(ic)
21839  end do
21840  end do
21841  end do
21842 10 continue
21843  do ia = 1, 4
21844  f(ia+1, ii) = ssf(ia)
21845  end do
21846  ! CONVERT RD ==> MRD M ==> CM
21847  f(3, ii) = f(3, ii)*1000.
21848  f(5, ii) = f(5, ii)*1000.
21849  f(2, ii) = f(2, ii)*100.
21850  f(4, ii) = f(4, ii)*100.
21851  gpai = f(7, ii)/xmat
21852  bpai = sqrt(1.-1./(gpai*gpai))
21853  vpai = vl*bpai
21854  trt = 100.*ssf(5)/vpai
21855  f(6, ii) = f(6, ii) + trt
21856  return
21857  end subroutine cobeam
21858  ! *******************************************************************
21859  ! SUBROUTINE disp
21860  ! Compute the dispersion dE/E with respect to the center of
21861  ! gravity of the bunch
21862  ! *******************************************************************
21863  subroutine disp
21864  implicit real *8(a-h, o-z)
21865  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21866  common /faisc/f(10, iptsz), imax, ngood
21867  common /etcom/cog(8), exten(17), fd(iptsz)
21868  common /mcs/imcs, ncstat, cstat(20)
21869  common /consta/vl, pi, xmat, rpel, qst
21870 
21871  gcog = 0.
21872  do i = 1, ngood
21873  gcog = f(7, i)/xmat + gcog
21874  end do
21875  gcog = gcog/float(ngood)
21876  bcog = sqrt(1.-1./(gcog*gcog))
21877  do i = 1, ngood
21878  gpai = f(7, i)/xmat
21879  if (gpai>=1.) then
21880  bpai = sqrt(1.-1./(gpai*gpai))
21881  else
21882  bpai = 0.
21883  end if
21884  fd(i) = bpai/bcog*gpai/gcog
21885  end do
21886  return
21887  end subroutine disp
21888  ! old do ist=1,ncstat
21889  ! old gcog=0.
21890  ! old nii=0
21891  ! old do ii=1,ngood
21892  ! old if(f(9,ii).eq.cstat(ist)) then
21893  ! old gcog=gcog+f(7,ii)/xmat
21894  ! old nii=nii+1
21895  ! old endif
21896  ! old enddo
21897  ! old gcog=gcog/float(nii)
21898  ! old bcog=sqrt(1.-1./(gcog*gcog))
21899  ! old DO II=1,NGOOD
21900  ! old if(f(9,ii).eq.cstat(ist)) then
21901  ! old gpai=f(7,ii)/xmat
21902  ! old bpai=sqrt(1.-1./(gpai*gpai))
21903  ! old fd(ii)=(gpai*bpai)/(gcog*bcog)
21904  ! old endif
21905  ! old enddo
21906  ! old enddo
21907  ! old return
21908  ! old end
21909  ! *******************************************************************
21910  ! SUBROUTINE zrotat(zrot)
21911  ! BEAM ROTATION
21912  ! the transverse coordinates X and Y may be rotated
21913  ! through an angle about the axis tangent to the
21914  ! central trajectory at the point in question.
21915  ! *******************************************************************
21916  subroutine zrotat(zrot)
21917  implicit real *8(a-h, o-z)
21918  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21919  common /faisc/f(10, iptsz), imax, ngood
21920  common /grot/rzot, izrot
21921  common /consta/vl, pi, xmat, rpel, qst
21922  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
21923  logical izrot
21924  dimension rs(6, 6), ff(6), fc(6)
21925 
21926  write (16, 100) zrot
21927 100 format (/, 20x, 'BEAM ROTATION ', f10.4, ' degrees ABOUT THE POSITIVE Z-AXIS', /)
21928  if (.not. izrot) then
21929  izrot = .true.
21930  rzot = zrot
21931  go to 500
21932  end if
21933  if (izrot) izrot = .false.
21934 500 continue
21935  ! Daves start
21936  idav = idav + 1
21937  iitem(idav) = 20
21938  dav1(idav, 1) = zrot
21939  ! initialize
21940  do ia = 1, 4
21941  do ib = 1, 4
21942  rs(ia, ib) = 0.
21943  end do
21944  end do
21945  ! Conversion DEG ==> RAD
21946  zrot = zrot*pi/180.
21947  rs44 = cos(zrot)
21948  rs(4, 4) = rs44
21949  rs(3, 3) = rs44
21950  rs(2, 2) = rs44
21951  rs(1, 1) = rs44
21952  rs24 = sin(zrot)
21953  rs(2, 4) = rs24
21954  rs(1, 3) = rs24
21955  rs(4, 2) = -rs24
21956  rs(3, 1) = -rs24
21957  do ii = 1, ngood
21958  ff(1) = f(2, ii)
21959  ff(2) = f(3, ii)
21960  ff(3) = f(4, ii)
21961  ff(4) = f(5, ii)
21962  do ia = 1, 4
21963  fc(ia) = 0.
21964  do ib = 1, 4
21965  fc(ia) = fc(ia) + ff(ib)*rs(ia, ib)
21966  end do
21967  end do
21968  f(2, ii) = fc(1)
21969  f(3, ii) = fc(2)
21970  f(4, ii) = fc(3)
21971  f(5, ii) = fc(4)
21972  end do
21973  ! 110 continue
21974  return
21975  end subroutine zrotat
21976  ! *******************************************************************
21977  ! SUBROUTINE zrotap(zrot)
21978  ! BEAM ROTATION
21979  ! the transverse coordinates X and Y may be rotated
21980  ! through an angle about the axis tangent to the
21981  ! central trajectory at the point in question.
21982  ! *******************************************************************
21983  subroutine zrotap(zrot)
21984  implicit real *8(a-h, o-z)
21985  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
21986  common /faisc/f(10, iptsz), imax, ngood
21987  common /grot/rzot, izrot
21988  common /consta/vl, pi, xmat, rpel, qst
21989  logical izrot
21990  dimension rs(6, 6), ff(6), fc(6)
21991 
21992  write (16, 100) zrot
21993 100 format (/, 20x, 'BEAM ROTATION ', f10.4, ' degrees ABOUT THE POSITIVE Z-AXIS', /)
21994  rzot = zrot
21995  ! Conversion DEG ==> RAD
21996  zrot = zrot*pi/180.
21997  rs44 = cos(zrot)
21998  rs(4, 4) = rs44
21999  rs(3, 3) = rs44
22000  rs(2, 2) = rs44
22001  rs(1, 1) = rs44
22002  rs24 = sin(zrot)
22003  rs(2, 4) = rs24
22004  rs(1, 3) = rs24
22005  rs(4, 2) = -rs24
22006  rs(3, 1) = -rs24
22007  do ii = 1, ngood
22008  ff(1) = f(2, ii)
22009  ff(2) = f(3, ii)
22010  ff(3) = f(4, ii)
22011  ff(4) = f(5, ii)
22012  do ia = 1, 4
22013  fc(ia) = 0.
22014  do ib = 1, 4
22015  fc(ia) = fc(ia) + ff(ib)*rs(ia, ib)
22016  end do
22017  end do
22018  f(2, ii) = fc(1)
22019  f(3, ii) = fc(2)
22020  f(4, ii) = fc(3)
22021  f(5, ii) = fc(4)
22022  end do
22023  return
22024  end subroutine zrotap
22025  ! *******************************************************************
22026  ! SUBROUTINE aliner
22027  ! ALIGNMENT errors:
22028  ! HORIZONTAL : XL(cm) XLP(mrad)
22029  ! VERTICAL : YL(cm) YLP(mrad)
22030  ! *******************************************************************
22031  subroutine aliner
22032  implicit real *8(a-h, o-z)
22033  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22034  common /alin/xl, yl, xpl, ypl
22035  common /faisc/f(10, iptsz), imax, ngood
22036 
22037  write (16, 100) xl, yl, xpl, ypl
22038 100 format (/, 5x, ' KICK x(cm) y(cm) : ', 2(e12.5,2x), /, 5x, ' KICK xp(mrad) yp(mrad): ', 2(e12.5,2x), //)
22039  ! CALCUL DES COORDONNEES DES TRAJECTOIRES
22040  ! UNITES = CM-MRD
22041  do ii = 1, ngood
22042  f(2, ii) = f(2, ii) + xl
22043  f(4, ii) = f(4, ii) + yl
22044  f(3, ii) = f(3, ii) + xpl
22045  f(5, ii) = f(5, ii) + ypl
22046  end do
22047  return
22048  end subroutine aliner
22049  ! *******************************************************************
22050  ! SUBROUTINE randali
22051  ! RANDOM ALIGNMENT errors :
22052  ! HORIZONTAL PLANE : XL(cm) XLP(mrad)
22053  ! VERTICAL PLANE : YL(cm) YLP(mrad)
22054  ! *******************************************************************
22055  subroutine randali
22056  implicit real *8(a-h, o-z)
22057  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22058  common /alin/xl, yl, xpl, ypl
22059  common /faisc/f(10, iptsz), imax, ngood
22060  common /apel/iapel
22061  dimension trans(1)
22062 
22063  write (16, *) ' random error in alignment with:'
22064  write (16, 100) xl, yl, xpl, ypl
22065 100 format (/, 5x, ' KICK x(cm) y(cm) : ', 2(e12.5,2x), /, 5x, ' KICK xp(mrad) yp(mrad): ', 2(e12.5,2x), //)
22066  len = 1
22067  rdcf = .5
22068  call rlux(trans, len)
22069  if (trans(1)<=rdcf) sign = -1.
22070  if (trans(1)>rdcf) sign = 1.
22071  call rlux(trans, len)
22072  xla = xl*sign*trans(1)
22073  call rlux(trans, len)
22074  if (trans(1)<=rdcf) sign = -1.
22075  if (trans(1)>rdcf) sign = 1.
22076  call rlux(trans, len)
22077  yla = yl*sign*trans(1)
22078  call rlux(trans, len)
22079  if (trans(1)<=rdcf) sign = -1.
22080  if (trans(1)>rdcf) sign = 1.
22081  call rlux(trans, len)
22082  xpla = xpl*sign*trans(1)
22083  call rlux(trans, len)
22084  if (trans(1)<=rdcf) sign = -1.
22085  if (trans(1)>rdcf) sign = 1.
22086  call rlux(trans, len)
22087  ypla = ypl*sign*trans(1)
22088  write (16, 100) xla, yla, xpla, ypla
22089  do ii = 1, ngood
22090  f(2, ii) = f(2, ii) + xla
22091  f(4, ii) = f(4, ii) + yla
22092  f(3, ii) = f(3, ii) + xpla
22093  f(5, ii) = f(5, ii) + ypla
22094  end do
22095  return
22096  end subroutine randali
22097  ! *******************************************************************
22098  ! SUBROUTINE matrix
22099  ! print first and second order matrix of a lens
22100  ! *******************************************************************
22101  subroutine matrix
22102  implicit real *8(a-h, o-z)
22103  common /bloc11/r(6, 6), t(6, 6, 6)
22104  common /secdr/iseor
22105  logical iseor
22106 
22107  write (16, *) ' TRANSPORT MATRIX (m-rd)'
22108  write (16, *) ' FIRST ORDER TRANSPORT********'
22109  do ia = 1, 6
22110  write (16, 100)(r(ia,ib), ib=1, 6)
22111  end do
22112 100 format (6(3x,e12.5))
22113  write (16, *) ' *************************************************'
22114  if (iseor) then
22115  write (16, *) ' SECOND ORDER TRANSPORT (m-rd)********'
22116  do ia = 1, 6
22117  do ib = 1, 6
22118  do ic = 1, 6
22119  if (t(ia,ib,ic)/=6.*0) write (16, 101) ia, ib, ic, t(ia, ib, ic)
22120  end do
22121  end do
22122  end do
22123  write (16, *) ' *************************************************'
22124  end if
22125 101 format (' T', 3(i1), 3x, e12.5)
22126  return
22127  end subroutine matrix
22128  ! *******************************************************************
22129  ! SUBROUTINE egun(fmult,indp)
22130  ! method:Bode's rule
22131  ! read the axial field of the DC gun field from disk
22132  ! z (m) E(z) is normalized
22133  ! *******************************************************************
22134  subroutine egun(fmult, indp)
22135  implicit real *8(a-h, o-z)
22136  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22137  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
22138  common /faisc/f(10, iptsz), imax, ngood
22139  common /consta/vl, pi, xmat, rpel, qst
22140  common /azlist/icont, iprin
22141  common /dyn/tref, vref
22142  common /rigid/boro
22143  common /etcom/cog(8), exten(17), fd(iptsz)
22144  common /qmoyen/qmoy
22145  common /tapes/in, ifile, meta
22146  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
22147  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
22148  common /femt/iemgrw, iemqesg
22149  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
22150  common /compt/nrres, nrtre, nrbunc, nrdbun
22151  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
22152  common /dcspa/iesp
22153  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
22154  dimension gam(3000), xe(3000), xpe(3000), ye(3000), ype(3000)
22155  character *1 cr
22156  logical flgsc, iesp, ichaes, iemgrw
22157  ! print out on terminal of transport element # on one and the same line
22158  nrres = nrres + 1
22159  cr = char(13)
22160  write (6, 8254) nrtre, nrres
22161 8254 format ('Transport element:', i5, ' Accelerating element:', i5)
22162  write (6, *) 'EGUN calculation started'
22163  ! energy at the entrance
22164  we = 0.
22165  do i = 1, ngood
22166  we = we + f(7, i)
22167  end do
22168  we = we/float(ngood) - xmat
22169  ! indp: define the number of space charge computations
22170  ! indp = 1 : 8 space charge computations. The EGUN field is divided in 16 elements
22171  ! indp = 2 : 16 space charge computation. in 32 elements
22172  ! indp = 3 : 32 space charge computation. in 64 elements
22173  if (indp>3) indp = 3
22174  if (indp==1) ipart = 16
22175  if (indp>=2) ipart = 32
22176  if (indp==3) ipart = 64
22177  ! research the number of steps w.r.t. the input energy
22178  ! convert energy: MeV --> eV
22179  we = we*1.e06
22180  weinf = 19.99
22181  if (we<=weinf) then
22182  write (6, *) ' Energy at the cathode: ', we, ' eV is below the lower limit of 20 eV '
22183  stop
22184  end if
22185  ! read egun field on the disk
22186  e0 = xmat
22187  vlm = vl*1.e-02
22188  read (22, *) npt
22189  do i = 1, npt
22190  read (22, *) xspl(i), yspl(i)
22191  end do
22192  zinf = xspl(1)
22193  zsup = xspl(npt)
22194  egl = zsup - zinf
22195  call deriv2(npt)
22196  elgun = egl*100.
22197  ! PLOT
22198  if (iprf==1) call stapl(davtot*10.)
22199  ! start prints in file 'short.data'
22200  idav = idav + 1
22201  idavs = idav
22202  iitem(idav) = 13
22203  dav1(idav, 1) = egl*1000.
22204  dav1(idav, 2) = fmult
22205  davtot = davtot + elgun
22206  dav1(idav, 4) = elgun*10.
22207  ! divide the length in ipart partitions
22208  ! the space charge computations are made at the middle of each partition
22209  eglp = egl/float(ipart)
22210  ! eglsc :space charge acting lenght (cm) (of each part)
22211  scl = float(ipart)/2.
22212  eglsc = egl*100./scl
22213  ! compute the EGUN field (MV)
22214  npas = 200
22215  xpas = eglp/float(npas)
22216  xnhf = 0
22217  dcfld = 0.
22218  do i = 1, npas
22219  fpos = xnhf*xpas
22220  tspl = spline(npt, fpos)*fmult
22221  dcfld = dcfld + qst*tspl*xpas
22222  xnhf = xnhf + 1.
22223  end do
22224  ! 4443 format(2x,i5,3(2x,e12.5))
22225  dav1(idav, 3) = dcfld*1000.
22226  write (16, 101) elgun, fmult, dcfld*1000.
22227 101 format (5x, ' FIELD LENGTH =', f7.3, ' CM ', /, 5x, ' FIELD CREST=', f10.4, ' MV/m', /5x, ' FIELD STENGTH= ', &
22228  e12.5, ' kV', /)
22229  ! omment write(49,5557)
22230  ! omment5557 format(6x,'z(m)',14x,'x(m)',14x,'xp(rad)',11x,'y(m)',14x,
22231  ! omment * 'yp(rad)',11x,'energy(MeV)')
22232  ! **** demarrage sur 0.5 mm (?) soit 0.5 e-03 m
22233  ! thresold of energy
22234  swe1 = 19.99
22235  swe2 = 79.99
22236  npas = 200
22237  if (we<swe1) npas = 400
22238  if (we<swe2) npas = 300
22239  xlstart = 0.5e-03
22240  xpas = xlstart/float(npas)
22241  npas1 = npas + 1
22242  iflg = -1
22243  xnht = 0.
22244  flgsc = .false.
22245 501 continue
22246  if (iflg==ipart) go to 500
22247  do j = 1, ngood
22248  xnh = xnht
22249  qc = f(9, j)
22250  gam0 = f(7, j)/e0
22251  gam(1) = gam0
22252  tof = f(6, j)
22253  ! the tranverse coordinates are converted in (m,rad)
22254  x0 = f(2, j)*1.e-02
22255  y0 = f(4, j)*1.e-02
22256  t0 = f(3, j)*1.e-03
22257  p0 = f(5, j)*1.e-03
22258  ! Pitch transformation
22259  xe0 = x0*(gam0*gam0-1.)**0.25
22260  xpe0 = t0*(gam0*gam0-1.)**0.25
22261  ye0 = y0*(gam0*gam0-1.)**0.25
22262  ype0 = p0*(gam0*gam0-1.)**0.25
22263  fpos = xnh*xpas
22264  tspl = spline(npt, fpos)*fmult
22265  dgam = (qc/e0)*tspl
22266  dgami = dgam
22267  xpe0 = xpe0 + .5*xe0*gam0*dgam/(gam0*gam0-1)
22268  ype0 = ype0 + .5*ye0*gam0*dgam/(gam0*gam0-1)
22269  a1 = qc*qc/(4.*e0*e0)
22270  a2 = qc/(e0*vlm)
22271  xe(1) = xe0
22272  xpe(1) = xpe0
22273  ye(1) = ye0
22274  ype(1) = ype0
22275  do i = 2, npas1
22276  i1 = i - 1
22277  fpos1 = xnh*xpas
22278  fpos2 = (xnh+0.25)*xpas
22279  fpos3 = (xnh+0.5)*xpas
22280  fpos4 = (xnh+0.75)*xpas
22281  fpos5 = (xnh+1.)*xpas
22282  tspl1 = spline(npt, fpos1)*fmult
22283  tspl2 = spline(npt, fpos2)*fmult
22284  tspl3 = spline(npt, fpos3)*fmult
22285  tspl4 = spline(npt, fpos4)*fmult
22286  tspl5 = spline(npt, fpos5)*fmult
22287  cw = (qc/e0)*xpas/90.
22288  tspl = 7.*tspl1 + 32.*tspl2 + 12.*tspl3 + 32.*tspl4 + 7.*tspl5
22289  gam(i) = cw*tspl + gam(i1)
22290  gam1 = gam(i1)
22291  gam5 = gam(i)
22292  dgam1 = (qc/e0)*tspl1
22293  cof1 = (gam5-gam1)/(xpas*xpas)
22294  cof2 = dgam1/xpas
22295  cof = cof1 - cof2
22296  gam2 = gam1 + dgam1*xpas/4. + cof*xpas*xpas/16.
22297  gam3 = gam1 + dgam1*xpas*0.5 + cof*xpas*xpas/4.
22298  gam4 = gam1 + dgam1*xpas*0.75 + cof*9.*xpas*xpas/16.
22299  gams1 = gam1*gam1
22300  gams2 = gam2*gam2
22301  gams3 = gam3*gam3
22302  gams4 = gam4*gam4
22303  gams5 = gam5*gam5
22304  ! omment bgt1=(gams1-1.)**1.5
22305  bgt2 = (gams2-1.)**1.5
22306  bgt3 = (gams3-1.)**1.5
22307  bgt4 = (gams4-1.)**1.5
22308  bgt5 = (gams5-1.)**1.5
22309  tslpt = 8.*tspl2/bgt2 + 6.*tspl3/bgt3 + 24.*tspl4/bgt4 + 7.*tspl5/bgt5
22310  dt = a2*xpas*xpas*tslpt/90.
22311  bet = sqrt(1.-1./gams1)
22312  tof = tof + xpas/(vlm*bet) + dt
22313  f(7, j) = gam(i)*e0
22314  f(6, j) = tof
22315  bg1 = (gams1+2.)/((gams1-1.)*(gams1-1.))
22316  bg2 = (gams2+2.)/((gams2-1.)*(gams2-1.))
22317  bg3 = (gams3+2.)/((gams3-1.)*(gams3-1.))
22318  bg4 = (gams4+2.)/((gams4-1.)*(gams4-1.))
22319  bg5 = (gams5+2.)/((gams5-1.)*(gams5-1.))
22320  bgts1 = bg1*tspl1*tspl1
22321  bgts2 = bg2*tspl2*tspl2
22322  bgts3 = bg3*tspl3*tspl3
22323  bgts4 = bg4*tspl4*tspl4
22324  bgts5 = bg5*tspl5*tspl5
22325  ! gtpm=bgts1+3.*bgts2+3.*bgts3+bgts4
22326  gtpm = 7.*bgts1 + 32.*bgts2 + 12.*bgts3 + 32.*bgts4 + 7.*bgts5
22327  ! gtm=bgts1+2.*bgts2+bgts3
22328  gtm = 7.*bgts1 + 24.*bgts2 + 6.*bgts3 + 8.*bgts4
22329  ! gtpz=bgts2+2.*bgts3+bgts4
22330  gtpz = 8.*bgts2 + 6.*bgts3 + 24.*bgts4 + 7.*bgts5
22331  gtm1 = 2.*bgts2 + 3.*bgts3 + 18.*bgts4 + 7.*bgts5
22332  de = -a1*xpas*xpas*gtm/90.
22333  de1 = -a1*xpas*xpas*xpas*gtm1/90.
22334  dpe1 = -a1*xpas*gtpm/90.
22335  dpe2 = -a1*xpas*xpas*gtpz/90.
22336  dxpe1 = dpe1*xe(i1)
22337  dype1 = dpe1*ye(i1)
22338  dxpe2 = dpe2*xpe(i1)
22339  dype2 = dpe2*ype(i1)
22340  dxe = de*xe(i1) + de1*xpe(i1)
22341  dye = de*ye(i1) + de1*ype(i1)
22342  xpe(i) = xpe(i1) + dxpe1 + dxpe2
22343  ype(i) = ype(i1) + dype1 + dype2
22344  xe(i) = xe(i1) + dxe + xpe(i1)*xpas
22345  ye(i) = ye(i1) + dye + ype(i1)*xpas
22346  ! back to the real variables and convert to (cm,mrad)
22347  gamm1 = (gams5-1.)**0.25
22348  gamm2 = (gams5-1.)**1.25
22349  dgam = (qc/e0)*tspl5
22350  xi = xe(i)/gamm1
22351  xpi = xpe(i)/gamm1 - xe(i)*gam(i)*dgam/(gamm2*2.)
22352  yi = ye(i)/gamm1
22353  ypi = ype(i)/gamm1 - ye(i)*gam(i)*dgam/(gamm2*2.)
22354  ! convert in cm and mrd
22355  f(2, j) = xi*1.e02
22356  f(4, j) = yi*1.e02
22357  f(3, j) = xpi*1.e03
22358  f(5, j) = ypi*1.e03
22359  ! ***** follow prtcl ifpt not active ************
22360  ! omment if(j.eq.ifpt)
22361  ! omment * write(49,4445) fpos5,xi,xpi,yi,ypi,e0*(gam5-1.)
22362  ! omment4445 format(6(2x,e12.5))
22363  xnh = xnh + 1.
22364  end do
22365  end do
22366  iflg = iflg + 1
22367  xnht = xnh
22368  if (iflg==0) then
22369  if (indp==1) npas = 96
22370  if (indp==2) npas = 48
22371  if (indp==3) npas = 24
22372  npas1 = npas + 1
22373  xlres = egl - xlstart
22374  xpas = xlres/(float(npas)*float(ipart))
22375  xnht = fpos5/xpas
22376  flgsc = .true.
22377  dav1(idavs, 7) = tspl5
22378  dav1(idav, 5) = xlstart*1000.
22379  call disp
22380  go to 501
22381  end if
22382  if (iflg==1) then
22383  if (indp==1) npas = 48
22384  if (indp==2) npas = 24
22385  if (indp==3) npas = 12
22386  npas1 = npas + 1
22387  xlres = egl - xlstart
22388  xpas = xlres/(float(npas)*float(ipart))
22389  xnht = fpos5/xpas
22390  end if
22391  if (.not. flgsc) then
22392  flgsc = .true.
22393  call disp
22394  go to 501
22395  end if
22396  if (flgsc) then
22397  if (ichaes) then
22398  ! Charge space
22399  iesp = .true.
22400  call cesp(eglsc)
22401  iesp = .false.
22402  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
22403  end if
22404  call disp
22405  flgsc = .false.
22406  ! reference ( c.o.g. of the bunch)
22407  tref = 0.
22408  gref = 0.
22409  do ij = 1, ngood
22410  tref = tref + f(6, ij)
22411  gref = gref + f(7, ij)/e0
22412  end do
22413  tref = tref/float(ngood)
22414  gref = gref/float(ngood)
22415  bets = sqrt(1.-1./(gref*gref))
22416  vref = bets*vl
22417  ! omment call emiprt(0)
22418  write (16, 562) fpos5*1000, tref, bets, tspl5
22419  write (6, 1562) fpos5*1000, bets, cr
22420 562 format (' ref.(c.o.g.) at ', e12.5, ' mm of the cathode', /, 5x, ' tof: ', e12.5, ' sec beta: ', e12.5, &
22421  ' field (MV/m) ', e12.5)
22422 1562 format (' EGUN: at ', e12.5, ' mm from the cathode; beta: ', e12.5, a1, $)
22423  go to 501
22424  end if
22425 500 continue
22426  write (6, *)
22427  write (6, *) 'EGUN calculation finished'
22428  ! reference ( c.o.g. of the bunch)
22429  tref = 0.
22430  gref = 0.
22431  do i = 1, ngood
22432  tref = tref + f(6, i)
22433  gref = gref + f(7, i)/e0
22434  end do
22435  tref = tref/float(ngood)
22436  gref = gref/float(ngood)
22437  bets = sqrt(1.-1./(gref*gref))
22438  write (16, 561) tref, bets
22439 561 format (' ref. at output of the DC gun', /, 5x, ' tof: ', e12.5, ' sec beta: ', e12.5)
22440  vref = bets*vl
22441  ! new magnetic rigidity of the reference
22442  xmor = xmat*bets*gref
22443  boro = 33.356*xmor*1.e-01/qst
22444  dav1(idavs, 6) = bets
22445  dav1(idavs, 36) = ngood
22446  ! plots
22447  call stapl(davtot*10.)
22448  call emiprt(0)
22449  return
22450  end subroutine egun
22451  ! *******************************************************************
22452  ! SUBROUTINE scheff1_swesson(int)
22453  ! 21-Apr-2014: This routine is NOT used by DYNAC
22454  ! comment SUBROUTINE scheff1(int)
22455  ! non relativistic SCHEFF space charge method
22456  ! SCE(i) (for ISCSP=3 only)
22457  ! int=0: initiate the arrays
22458  ! SCE(1)=BEAMC (as above)
22459  ! SCE(2)=r extension in rms multiples
22460  ! SCE(3)=z extension in rms multiples
22461  ! SCE(4)=no. of radial mesh intervals (le 20)
22462  ! SCE(5)=no. of longitudinal mesh intervals (le 40)
22463  ! SCE(6)=no. of adjacent bunches, applicable for buncher studies
22464  ! and should be 0 for linac dynamics
22465  ! SCE(7)=pulse length, if not beta lambda.(transport studies)
22466  ! distance bewteen beam pulses input zero to get default
22467  ! "beta lambda"; units are cm
22468  ! SCE(8)=determines frequency of calculating mesh size. see pard
22469  ! SCE(9)=option to integrate space charge forces over box
22470  ! if.eq.0. no integration. see sub gaus for further
22471  ! explanation.
22472  ! SCE(10)=same meaning as SCE10 above
22473  ! *******************************************************************
22474  subroutine scheff1_swesson(int)
22475  implicit real *8(a-h, o-z)
22476  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
22477  common /dyn/tref, vref
22478  common /cmpte/iell
22479  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
22480  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
22481  common /hermt/afxt(22), afyt(22), afzt(22)
22482  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
22483  common /consta/vl, pi, xmat, rpel, qst
22484  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
22485  common /faisc/f(10, iptsz), imax, ngood
22486  common /cdek/dwp(iptsz)
22487  common /beamsa/fs(7, iptsz)
22488  common /dcspa/iesp
22489  common /compt/nrres, nrtre, nrbunc, nrdbun
22490  common /posc/xpsc
22491  logical ichaes, iesp
22492  common /bg/bsc, gsc, phis, wsync
22493  ! named common bg, contains beta and gamma as determined in pardyn.
22494  ! they may be values at beginning of cell, end of cell, or mid-way.
22495  common /fldcom/rp, zp, pl, opt, nip
22496  common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
22497  rss(20), ismax(40), iemax(41)
22498  common /rcshef/sce(20)
22499  ! set up field tables
22500  if (int==0) then
22501  beami = beamc/1000.0
22502  wavel = 2.*pi*vl/fh
22503  freq = fh/(2.*pi)
22504  btazro = vref/vl
22505  frrms = sce(2)
22506  fzrms = sce(3)
22507  nr = idint(sce(4))
22508  nz = idint(sce(5))
22509  nip = idint(sce(6))
22510  opt = sce(9)
22511  ! omment if(ncell.gt.0) pl=cell(4,ncell)
22512  if (sce(7)>0.) pl = sce(7)
22513  pl = btazro*wavel
22514  nr1 = nr + 1
22515  nz1 = nz + 1
22516  im1 = nr*nz
22517  im2 = nr1*nz1
22518  im3 = nr1*nz
22519  na = 1
22520  nb = ngood
22521  nq = nb - na + 1
22522  return
22523  end if
22524  beami = beamc/1000.0
22525  if (beami==0. .or. scdist==0.) return
22526  iell = iell + 1
22527  write (16, *) ' *call SCHEFF ', iell
22528  call pintim
22529  call sizrms(0, xrms, yrms, zrms, zz)
22530  write (16, 6875) xrms, yrms, zrms
22531  ! write the size rms in the output file 17
22532  ! omment write(17,25) iell,xrms,yrms,zrms
22533  ! omment25 format(2x,i5,3(2x,e12.5))
22534 6875 format (' RMS size(m)', e12.5, 2x, e12.5, 2x, e12.5)
22535  rrms = sqrt(xrms*xrms+yrms*yrms)
22536  ! change unit: m==>cm
22537  zrms1 = zrms*100.
22538  rrms = rrms*100.
22539  dr = rrms*frrms/float(nr)
22540  dz = zrms1*fzrms/float(nz)
22541  rmax = float(nr)*dr
22542  ! load rm, zm, rs, zs
22543  rm(1) = 0.0
22544  do i = 2, nr1
22545  rm(i) = float(i-1)*dr
22546  rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
22547  rss(i-1) = 0.5*(rm(i-1)+rm(i))
22548  rs(i-1) = sqrt(rssq(i-1))
22549  end do
22550  zs = .5*dz
22551  do i = 1, nz1
22552  zm(i) = float(i-1)*dz
22553  zzs(i) = zm(i) + zs
22554  end do
22555  hl = float(nz)*zs
22556  ! load ers and ezs
22557  ! mesh dimensions are in cm. ers and ezs are in 1/cm.
22558  ! c1, c2 and c3 are in cm., and c4 is in mev-cm.
22559  ! q=coulombs/point. (2/pi)*e/(4*pi*epsilon)=572167 cm mev/coul.
22560  q = beami/(freq*float(nq))
22561  c1 = 572167.*q/xmat
22562  l = 0
22563  do k = 1, nr
22564  rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
22565  if (opt==0.) rfac = 1.
22566  do j = 1, nz
22567  zp = zm(j+1)
22568  do i = 1, nr1
22569  rp = rm(i)
22570  if (opt==0.) call flds(rs(k), zs, er1, ez1)
22571  if (opt==0.) go to 35
22572  call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
22573 35 l = l + 1
22574  ers(l) = c1*er1/rfac
22575  ezs(l) = c1*ez1/rfac
22576  end do
22577  end do
22578  end do
22579  if (beamc==0. .or. scdist==0.) return
22580  dz1 = scdist/100.
22581  dist = scdist
22582  write (16, *) ' fields acting length(cm): ', dist
22583  ! evaluate and apply space charge effects.
22584  ! phimc=phi of mesh center.
22585  ! Shifts particle coordinates to a single point in time. Uses
22586  ! a linear shift
22587  ! Beam c.g.
22588  xbar = 0.
22589  ybar = 0.
22590  zbar = 0.
22591  brmoy = 0.
22592  trmoy = 0.
22593  do np = 1, ngood
22594  gpai = f(7, np)/xmat
22595  brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
22596  trmoy = trmoy + f(6, np)
22597  end do
22598  trmoy = trmoy/float(ngood)
22599  phimc = trmoy*fh
22600  pbar = phimc
22601  beta = brmoy/float(ngood)
22602  gsc = 1./sqrt(1.-beta*beta)
22603  bg = beta*gsc
22604  c2 = beta*wavel/(2.*pi)
22605  gmsq = 1. + bg**2
22606  c3 = dist/(bg*beta*gmsq)
22607  c4 = dist*xmat
22608  gam = sqrt(gmsq)
22609  c5 = 1./(gam*(gam+1.))
22610  ! evaluate ng, xbar, ybar
22611  ng = 0
22612  xbar = 0.
22613  ybar = 0.
22614  xsq = 0.
22615  ysq = 0.
22616  do np = 1, ngood
22617  ng = ng + 1
22618  x = f(2, np)
22619  y = f(4, np)
22620  xbar = xbar + x
22621  ybar = ybar + y
22622  xsq = xsq + x**2
22623  ysq = ysq + y**2
22624  end do
22625  eng = float(ngood)
22626  xbar = xbar/eng
22627  ybar = ybar/eng
22628  ! the mesh center is phi*syn
22629  xsq = xsq/eng
22630  ysq = ysq/eng
22631  epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
22632  epsqi = 1./epsq
22633  xfac = 2./(epsq+1.)
22634  yfac = epsq*xfac
22635  ! clear and load bins
22636  ng = 0
22637  do i = 1, im1
22638  aa(i) = 0.0
22639  end do
22640  do np = 1, ngood
22641  rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
22642  ! i=sqrt(rsq)/dr+1.
22643  r = sqrt(rsq)
22644  halfdr = dr*0.5
22645  i = idint(r/dr+1.0)
22646  if (i>nr) go to 120
22647  zph = f(6, np)*fh
22648  z = -c2*(zph-phimc)
22649  if (abs(z)>=hl) go to 120
22650  ! ------distribute charge among adjacent bins.
22651  ng = ng + 1
22652  zz = z + hl
22653  jm1 = idint(zz/dz+1.)
22654  i1 = i + 1
22655  ! if (rsq.lt.rssq(i)) i1=i-1
22656  if (rsq<rss(i)) i1 = i - 1
22657  if (i1<1) i1 = 1
22658  if (i1>nr) i1 = nr
22659  j1 = jm1 + 1
22660  if (zz<zzs(jm1)) j1 = jm1 - 1
22661  if (j1<1) j1 = 1
22662  if (j1>nz) j1 = nz
22663  a = 1.
22664  ! if (i1.ne.i) a=(rsq-rssq(i1))/(rssq(i)-rssq(i1))
22665  if (r>halfdr) then
22666  rminsq = (r-halfdr)**2
22667  rmaxsq = (r+halfdr)**2
22668  if (i1<i) then
22669  a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
22670  else
22671  a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
22672  end if
22673  end if
22674  b = 1. - a
22675  cc = 1.
22676  if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
22677  d = 1. - cc
22678  k = (jm1-1)*nr + i
22679  aa(k) = aa(k) + a*cc
22680  k = k + i1 - i
22681  aa(k) = aa(k) + b*cc
22682  k = (j1-1)*nr + i
22683  aa(k) = aa(k) + a*d
22684  k = k + i1 - i
22685  aa(k) = aa(k) + b*d
22686 120 end do
22687  eng = ng
22688  ! find ismax for each j
22689  do j = 1, nz
22690  l = (j-1)*nr
22691  k = nr
22692  do i = 1, nr
22693  m = l + k
22694  if (aa(m)<=0.00) then
22695  k = k - 1
22696  go to 130
22697  else
22698  go to 140
22699  end if
22700 130 continue
22701  end do
22702 140 ismax(j) = k
22703  end do
22704  ! find iemax for each j
22705  iemax(1) = 1 + ismax(1)
22706  do j = 2, nz
22707  iemax(j) = 1 + max0(ismax(j-1), ismax(j))
22708  end do
22709  iemax(nz1) = 1 + ismax(nz)
22710  ! set er and ez to zero
22711  do i = 1, im2
22712  er(i) = 0.0
22713  ez(i) = 0.0
22714  end do
22715  ! sum up fields
22716  do js = 1, nz
22717  js1 = js + 1
22718  ism = ismax(js)
22719  if (ism==0) go to 220
22720  do is = 1, ism
22721  l = (js-1)*nr + is
22722  a1 = aa(l)
22723  if (a1==0.) go to 210
22724  l = (is-1)*im3
22725  do je = 1, js
22726  k1 = l + (js-je)*nr1
22727  n1 = (je-1)*nr1
22728  iem = iemax(je)
22729  if (iem<=1) go to 180
22730  do ie = 1, iem
22731  n = n1 + ie
22732  k = k1 + ie
22733  er(n) = er(n) + a1*ers(k)
22734  ez(n) = ez(n) - a1*ezs(k)
22735  end do
22736 180 end do
22737  do je = js1, nz1
22738  k1 = l + (je-js1)*nr1
22739  n1 = (je-1)*nr1
22740  iem = iemax(je)
22741  if (iem<=1) go to 200
22742  do ie = 1, iem
22743  n = n1 + ie
22744  k = k1 + ie
22745  er(n) = er(n) + a1*ers(k)
22746  ez(n) = ez(n) + a1*ezs(k)
22747  end do
22748 200 end do
22749 210 end do
22750 220 end do
22751  ! evaluate and apply impulse
22752  rrmax = 0.
22753  zzmax = 0.
22754  zzmin = 1000.
22755  npz = 0
22756  npr = 0
22757  do np = 1, ngood
22758  r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
22759  zph = f(6, np)*fh
22760  z = -c2*(zph-phimc)
22761  if (z>=zzmax) zzmax = z
22762  if (z<zzmin) zzmin = z
22763  if (r>=rrmax) rrmax = r
22764  if (r==0.) r = .000001
22765  xor = (f(2,np)-xbar)*xfac/r
22766  yor = (f(4,np)-ybar)*yfac/r
22767  if (r>rmax) then
22768  npr = npr + 1
22769  go to 230
22770  end if
22771  ! zph=f(6,np)*fh
22772  ! z=-c2*(zph-phimc)
22773  ! if(z.ge.zzmax) zzmax=z
22774  ! if(z.lt.zzmin) zzmin=z
22775  if (abs(z)>hl) then
22776  npz = npz + 1
22777  go to 230
22778  end if
22779  ! interpolate impulse within mesh.
22780  rb = r/dr
22781  i = idint(1.0+rb)
22782  a = rb - float(i-1)
22783  b = 1.0 - a
22784  zb = (z+hl)/dz
22785  j = idint(1.0+zb)
22786  c = zb - float(j-1)
22787  d = 1.0 - c
22788  l = i + (j-1)*nr1
22789  m = l + nr1
22790  crp = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
22791  cen = c4*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
22792  crp = crp*abs(f(9,np))
22793  cen = cen*abs(f(9,np))
22794  go to 260
22795  ! estimate impulse based on point charge at xbar,ybar,pbar.
22796 230 continue
22797  d = sqrt(z**2+r**2)
22798  rod3 = r/d**3
22799  zod3 = z/d**3
22800  if (nip==0) go to 250
22801  ! include neighboring bunches.
22802  do i = 1, nip
22803  xi = i
22804  do j = 1, 2
22805  s = z + xi*pl
22806  d = sqrt(s**2+r**2)
22807  rod3 = rod3 + r/d**3
22808  zod3 = zod3 + s/d**3
22809  xi = -xi
22810  end do
22811  end do
22812  ! evaluate impulse.
22813 250 continue
22814  crp = eng*c1*c3*rod3*pi/2.
22815  cen = eng*c1*c4*zod3*pi/2.
22816  crp = crp*abs(f(9,np))
22817  cen = cen*abs(f(9,np))
22818  ! apply impulse
22819 260 continue
22820  ! convert from mrad to rad
22821  f3 = f(3, np)*1.e-03
22822  f5 = f(5, np)*1.e-03
22823  dwc = f(7, np) - xmat
22824  dxp = crp*xor - f3*cen*c5/dwc
22825  dyp = crp*yor - f5*cen*c5/dwc
22826  if (.not. iesp) then
22827  ! load the entrance beam parameters for cavities or gaps
22828  do js = 1, 7
22829  f(js, np) = fs(js, np)
22830  end do
22831  f(3, np) = f(3, np) + dxp*1000.
22832  f(5, np) = f(5, np) + dyp*1000.
22833  f(2, np) = f(2, np) - dz1*dxp*100.*xpsc
22834  f(4, np) = f(4, np) - dz1*dyp*100.*xpsc
22835  dwp(np) = cen
22836  else
22837  f(3, np) = f(3, np) + dxp*1000.
22838  f(5, np) = f(5, np) + dyp*1000.
22839  f(7, np) = f(7, np) + cen
22840  end if
22841  end do
22842  return
22843  end subroutine scheff1_swesson
22844  ! *******************************************************************
22845  ! SUBROUTINE cpardyn(pib)
22846  ! --- make up a list of cell by cell RFQ data based on a file
22847  ! generated by the external code
22848 
22849  ! nc: cell number
22850  ! ityp = 0: Standard accelerating cell
22851  ! ityp = 1: Transition cell of type T
22852  ! ityp = 2: Transition cell of type E
22853  ! ityp = 3: Transition cell of type M
22854  ! ityp = 4: Fringe-field region from the potential function
22855  ! (after type T, M or accelerating cell)
22856  ! ityp = 5: Radial matching section based on coefficients
22857  ! ityp = 6: Radial matching section based on RMS shape defined in
22858  ! an external file
22859  ! ityp = 7: Fringe-field region; the profile is defined in an
22860  ! external file (after type T, M or accelerating cell)
22861  ! a(1): cell length (cm)
22862  ! a(2): coefficient A10 (no dimension)
22863  ! a(3): smallest aperture a of vanes (cm)
22864  ! a(4): modulation factor m (no dimension)
22865  ! a(5): mean aperture ( r0 ) of vanes (middle of cells) (cm)
22866  ! a(6): transverse radius of curvature (rh0) of the surface of
22867  ! electrodes at the vane tip (cm)
22868  ! a(7): phase (deg) (at the entrance of cells)
22869  ! a(8): factor FVOLT to be applied at the intervane potential
22870  ! (only for particles)
22871  ! VOLT = (1 + FVOLT )* (intervane voltage)
22872  ! a(9): intervane-voltage (KV)
22873 
22874  ! ipar: cell parity (like for PARMTEQ cells)
22875  ! --- Note: the last line in file must be:
22876  ! 0 0 0. 0. 0. 0. 0. 0. 0. 0. 0. 0
22877  ! *******************************************************************
22878  subroutine cpardyn(pib)
22879  implicit real *8(a-h, o-z)
22880  common /consta/vl, pi, xmat, rpel, qst
22881  common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
22882  common /rf2ptq/rfq1(500), rfq2(500), rfq3(500), rfq4(500), rfq6(500), rfq7(500), rfq8(500), rfq9(500)
22883  common /rf5ptq/tdvolt, rfq10(500), rfq11(500)
22884  common /rfq3ptq/itype(500), ipari(500), evens, evenr
22885  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
22886  common /dyn/tref, vref
22887  common /bonda/cbx(500), bbx(500), ablx(500), cby(500), bby(500), ably(500)
22888  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
22889  common /spff/xspf(400), yspf(400), sf(500), pf(500), qf(500)
22890  common /rms_prfl/npt, npf
22891  dimension a(16), vptq(16)
22892  character *80 vprof, fprof
22893  logical even, evens, evenr
22894  ! Do so by shifting particles belonging to the same bunch outside the (+/-) pib/2 (rad) window
22895  ! w.r.t.the REF to inside the (+/-) pib/2 window w.r.t.the COG
22896  if (abs(pib)>6.*0.) then
22897  pib = pi
22898  call accep_rfq(pib)
22899  end if
22900  erest = xmat
22901  ! --- for simulating PARMTEQ cells, odd cells have A01 positive and even cells have A01 negative
22902  ! --- even: logical flag, even = true ==> A01 is positive, otherwise A01 is negative
22903  even = .true.
22904  netc = 0
22905 50 continue
22906  ! --- read the data of the RFQ from the input file
22907  ! ****************************************************************
22908  ! --- read 11 parameters from unit 27), file 'myfile', in the form:
22909  ! nc ityp intervane-voltage (KV) cl(cm) A10 a(cm) m r0(cm) rho(cm) phase(deg) fvolt ipar
22910  netc = netc + 1
22911  read (27, *) nc, ityp, (vptq(j), j=1, 9), ipar
22912  if (ityp==6) then
22913  ! if the RMS is of type 6, get the filename of the RMS descriptor
22914  read (27, '(A80)') vprof
22915  write (16, *) 'Read RMS from file ', vprof
22916  end if
22917  if (ityp==7) then
22918  ! if the Fringe Field is of type 7, get the filename of the FF descriptor
22919  read (27, '(A80)') fprof
22920  write (16, *) 'Read Fringe Field from file ', fprof
22921  end if
22922  a(1) = vptq(2)
22923  a(2) = vptq(3)
22924  a(3) = vptq(4)
22925  a(4) = vptq(5)
22926  a(5) = vptq(6)
22927  a(6) = vptq(7)
22928  a(7) = vptq(8)
22929  a(8) = vptq(9)
22930  a(9) = vptq(1)
22931  ! **************************************************
22932  ! convert intervane voltage in MV
22933  a(9) = a(9)*1.e-03
22934  if (nc==1) tdvolt = a(9)
22935  ! ---- stop at the last line with nc = 0
22936  if (nc==0) go to 60
22937  if (nc>nceltot) go to 60
22938  itype(nc) = ityp
22939  ipari(nc) = ipar
22940  if (itype(nc)==5) then
22941  ! Radial matching section from potential function
22942  ! ---------------------------------------------------------------------------------------------
22943  ! Note: The total length L(rms) of the RMS must be the sum of the RMS-cell lengths in the
22944  ! Parmteq file. rho is equal to the distance between the axis and the vane, r0, at the
22945  ! exit of the RMS
22946  ! we have used the approximation of the modified Bessel functions for small arguments
22947  ! and we have negleted the terms of higher order in r greater than 2
22948  ! ----------------------------------------------------------------------------------------------
22949  write (16, *) 'RFQ RMS from potential function'
22950  cl = a(1)
22951  r0 = a(5)
22952  rh0 = a(6)
22953  phim = a(7)
22954  fact = 1. + a(8)
22955  xk = pi/(2.*cl)
22956  xq0 = 1./6.*xk*xk*rh0*rh0
22957  ! old sv aq=9./(8.*xq0)
22958  aq = 1./xq0
22959  ! --- limits x-vane y-vane
22960  cbx(nc) = 1.5*r0*1.e-02
22961  cby(nc) = 1.5*r0*1.e-02
22962  ablx(nc) = 0.
22963  ably(nc) = 0.
22964  bbx(nc) = 0.
22965  bby(nc) = 0.
22966  ! --- convert all parameters in units (MeV, m)
22967  ! rfq1(nc): Aq (no dimension)
22968  ! rfq2(nc): not used
22969  ! rfq3(nc): RMS length (m)
22970  ! rfq4(nc): phase RF (deg)
22971  ! rfq7(nc): mean aperture of the vane r0 (m)
22972  ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
22973  ! rfq10(nc):intervane voltage applied to the synchronous particle (kV)
22974  ! rfq11(nc):intervane voltage applied to the particles (kV)
22975 
22976  rfq1(nc) = aq
22977  rfq2(nc) = 0.
22978  rfq3(nc) = cl*1.e-02
22979  rfq4(nc) = phim
22980  rfq7(nc) = r0*1.e-02
22981  rfq9(nc) = fact
22982  rfq10(nc) = (1.+tvolt)*a(9)
22983  rfq11(nc) = (1.+avolt)*a(9)
22984  go to 50
22985  end if
22986  if (itype(nc)==6) then
22987  ! read from disk the RMS profile in the form (z,R(z)), with z,R in meter
22988  ! npt is the number of (z,R(z)) coordinates
22989  open (67, file=vprof, status='unknown')
22990  ! read(67,*)npt
22991  npt = 0
22992  do
22993  read (67, *, end=777) xspl(npt+1), yspl(npt+1)
22994  npt = npt + 1
22995  end do
22996 777 write (16, *) 'RFQ RMS from file with ', npt, ' data points'
22997  call deriv2(npt)
22998  ! cl; length of the RMS (in M)
22999  cl = xspl(npt)
23000  r0 = yspl(npt)
23001  phim = a(7)
23002  fact = 1. + a(8)
23003  ! --- limits x-vane y-vane
23004  cbx(nc) = 1.5*r0
23005  cby(nc) = 1.5*r0
23006  ablx(nc) = 0.
23007  ably(nc) = 0.
23008  bbx(nc) = 0.
23009  bby(nc) = 0.
23010  ! rfq1(nc) : not used
23011  ! rfq2(nc): not used
23012  ! rfq3(nc): RMS length (m)
23013  ! rfq4(nc): phase RF (deg)
23014  ! rfq7(nc): distance axe-vanes at the end of the RMS (m)
23015  ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
23016  ! rfq10(nc):intervane voltage applied to the synchronous particle (kV)
23017  ! rfq11(nc):intervane voltage applied to the particles (kV)
23018  ! rfq1(nc)=0.
23019  rfq2(nc) = 0.
23020  rfq3(nc) = cl
23021  rfq4(nc) = phim
23022  rfq7(nc) = r0
23023  rfq9(nc) = fact
23024  rfq10(nc) = (1.+tvolt)*a(9)
23025  rfq11(nc) = (1.+avolt)*a(9)
23026  close (67)
23027  ! cc write(16,579)nc,npt,cl,phim,r0,rfq10(nc),rfq11(nc)
23028  ! cc579 format(2(2x,i4),5(2x,e12.5))
23029  go to 50
23030  end if
23031  ! End Radial matching section
23032  ! --- Standard accelerationg cell
23033  if (itype(nc)==0) then
23034  cl = a(1)
23035  a10 = a(2)
23036  xa = a(3)
23037  xm = a(4)
23038  r0 = a(5)
23039  rh0 = a(6)
23040  ! fph : factor affecting the phase at entrance of cells (only available for type = 0)
23041  a(7) = fph*a(7)
23042  phim = a(7)
23043  fact = 1. + a(8)
23044  ! coefficient A01 (1/(cm*cm))
23045  alpha = rh0/r0
23046  a01 = 3.*(1.+5.*alpha)/(2.*r0*r0*(1.+7.*alpha))
23047  ! coefficient A03: (1/(cm**6) )
23048  a03 = -(1.+alpha)/(2.*r0**6*(1.+7.*alpha))
23049  ! coefficient A12: no dimensions
23050  xam = xa*xm
23051  a12 = 0.
23052  xk1 = 1. - a01*xa*xa - a03*(xa**6)
23053  yk2 = -1. + a01*xam*xam + a03*(xam**6)
23054  ! Bessel functions: I0(ka) I0(mka) I4(ka) I4(mka)
23055  xk = pi/cl
23056  za0 = xk*xa
23057  zam = za0*xm
23058  no = 0
23059  bi0 = bint(no, za0)
23060  ! old bi0=1.+za0*za0/4.+za0**4/64.+za0**6/2304.+za0**8/1.47456e05
23061  ! old bi0=bi0+za0**10/1.47456e07
23062  bim = bint(no, zam)
23063  ! old bim=1.+zam*zam/4.+zam**4/64.+zam**6/2304.+zam**8/1.47456e05
23064  ! old bim=bim+zam**10/1.47456e07
23065  no = 4
23066  bi4 = bint(no, za0)
23067  ! old bi4=(za0/2.)**4/24.
23068  ! old zaa0=za0*za0/4.
23069  ! old bi4=bi4+(za0/2.)**4*zaa0/120.
23070  ! old bi4=bi4+(za0/2.)**4*zaa0*zaa0/1440.
23071  bim4 = bint(no, zam)
23072  ! old zamm=zam*zam/4.
23073  ! old bim4=(zam/2.)**4/24.
23074  ! old bim4=bim4+(zam/2.)**4*zamm/120.
23075  ! old bim4=bim4+(zam/2.)**4*zamm*zamm/1440.
23076  den1 = bim4*bi0 - bim*bi4
23077  if (abs(den1)>1.e-09) a12 = (yk2*bi0-xk1*bim)/den1
23078  ! ********************************************************************************************
23079  ! NOTE: the coefficient A10 is read in the file 'myfile' but it also can be computed in Dynac
23080  ! from multipolar expansions (see the two following fortran lines):
23081  ! cc a10=0.
23082  ! cc if(abs(den1).gt.1.e-09) a10=(xk1*bim4-yk2*bi4)/den1
23083  ! ************************************
23084  ! or from first order computations (see the two following lines):
23085  ! cc dencc=xm*xm*bi0+bim
23086  ! cc a10=(xm*xm-1.)/dencc
23087  ! ********************************************************************************************
23088  ! --- convert all parameters in units (MeV, m)
23089  ! rfq1(nc): A01 ( 1/(m*m) )
23090  ! rfq2(nc): A10 (no dimension)
23091  ! rfq3(nc): cell length (m)
23092  ! rfq4(nc): phase RF (deg)
23093  ! rfq6(nc): A12 (no dimension)
23094  ! rfq7(nc): mean aperture of the vane r0 (m)
23095  ! rfq8(nc): A03 (1/(m**6)
23096  ! rfq9(nc): error factor F = 1 + a(8)
23097  ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
23098  ! rfq11(nc):intervane voltage applied to the particles (KV)
23099  ! --- odds cells have a01 positive, even cells have a01 negative
23100 
23101  rfq1(nc) = a01*1.e04
23102  ! --- limits x-vane y-vane
23103  ncf = (ipari(nc)/2)*2 - ipari(nc)
23104  if (ncf/=0) then
23105  ! odd number standard cell limits
23106  cbx(nc) = xa
23107  bbx(nc) = (4.*r0-xm*xa-3.*cbx(nc))/cl
23108  ablx(nc) = xa*xm/(cl*cl) - bbx(nc)/cl - cbx(nc)/(cl*cl)
23109  cby(nc) = xa*xm
23110  bby(nc) = (4.*r0-xa-3.*cby(nc))/cl
23111  ably(nc) = xa/(cl*cl) - bby(nc)/cl - cby(nc)/(cl*cl)
23112  else
23113  ! even number standard cell limits
23114  cbx(nc) = xm*xa
23115  bbx(nc) = (4.*r0-xa-3.*cbx(nc))/cl
23116  ablx(nc) = xa/(cl*cl) - bbx(nc)/cl - cbx(nc)/(cl*cl)
23117  cby(nc) = xa
23118  bby(nc) = (4.*r0-xm*xa-3.*cby(nc))/cl
23119  ably(nc) = xm*xa/(cl*cl) - bby(nc)/cl - cby(nc)/(cl*cl)
23120  end if
23121  ! 8526 continue
23122  ! conversion: cm --> m
23123  cbx(nc) = cbx(nc)*1.e-02
23124  ablx(nc) = ablx(nc)*1.e02
23125  cby(nc) = cby(nc)*1.e-02
23126  ably(nc) = ably(nc)*1.e02
23127  ! end limits ******************************
23128  rfq2(nc) = a10
23129  rfq3(nc) = cl*1.e-02
23130  rfq4(nc) = phim
23131  rfq6(nc) = a12
23132  rfq7(nc) = r0*1.e-02
23133  rfq8(nc) = a03*1.e12
23134  rfq9(nc) = fact
23135  rfq10(nc) = (1.+tvolt)*a(9)
23136  rfq11(nc) = (1.+avolt)*a(9)
23137  go to 50
23138  ! endif of itype(nc) = 0 (accelerating cell)
23139  end if
23140  if (itype(nc)==1) then
23141  ! ------ T-cell(ityp = 1) (must follows a standard cell and be followed by an M-cell or by fringe-field region)
23142  cl = a(1)
23143  xa = a(3)
23144  xm = a(4)
23145  r0 = a(5)
23146  phim = a(7)
23147  fact = 1. + a(8)
23148  xk = pi/(2.*cl)
23149  za0 = xk*xa
23150  zam = za0*xm
23151  ! Bessel functions
23152  no = 0
23153  bi0 = bint(no, za0)
23154  bim = bint(no, zam)
23155  bi3 = bint(no, 3.*za0)
23156  bim3 = bint(no, 3.*zam)
23157  ! coefficients A10 and A30 (no dimensions)
23158  t10k = xm*xm*bi0 + bim
23159  t30k = xm*xm*bi3 + bim3
23160  zr0 = xk*r0
23161  zr3 = 3.*zr0
23162  bir0 = bint(no, zr0)
23163  bir3 = bint(no, zr3)
23164  alpk = 0.
23165  if (abs(bir3)/=6.*0.) alpk = bir0/bir3
23166  dtk = t10k + alpk*t30k/3.
23167  a10 = 0.
23168  if (abs(dtk)/=6.*0.) a10 = (xm*xm-1.)/dtk
23169  a30 = alpk*a10/3.
23170  ! -- limits x-vane y-vane
23171  cbx(nc) = xm*xa
23172  bbx(nc) = (4.*r0-xa-3.*cbx(nc))/(2.*cl)
23173  ablx(nc) = xa/(4.*cl*cl) - bbx(nc)/(2.*cl) - cbx(nc)/(4.*cl*cl)
23174  cby(nc) = xa
23175  bby(nc) = (4.*r0-xm*xa-3.*cby(nc))/(2.*cl)
23176  ably(nc) = xm*xa/(4.*cl*cl) - bby(nc)/(2.*cl) - cby(nc)/(4.*cl*cl)
23177  ! conversion: cm --> m
23178  cbx(nc) = cbx(nc)*1.e-02
23179  ablx(nc) = ablx(nc)*1.e02
23180  cby(nc) = cby(nc)*1.e-02
23181  ably(nc) = ably(nc)*1.e02
23182  ! end limits ******************************
23183  ! --- convert all parameters in units (MeV, m)
23184  ! rfq1(nc): A30 (no dimension)
23185  ! rfq2(nc): A10 (no dimension)
23186  ! rfq3(nc): cell length (m)
23187  ! rfq4(nc): phase RF (deg)
23188  ! rfq7(nc): mean aperture of the vane r0 (m)
23189  ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
23190  ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
23191  ! rfq11(nc):intervane voltage applied to the particles (KV)
23192 
23193  rfq1(nc) = a30
23194  rfq2(nc) = a10
23195  rfq3(nc) = cl*1.e-02
23196  rfq4(nc) = phim
23197  rfq7(nc) = r0*1.e-02
23198  rfq9(nc) = fact
23199  rfq10(nc) = (1.+tvolt)*a(9)
23200  rfq11(nc) = (1.+avolt)*a(9)
23201  go to 50
23202  ! endif for T-cell
23203  end if
23204  if (itype(nc)==2) then
23205  ! --- E-cell(itype = 2) must follow a RMS and be folllowed by an even standard cell
23206  cl = a(1)
23207  xa = a(3)
23208  xm = a(4)
23209  r0 = a(5)
23210  a(7) = fph*a(7)
23211  phim = a(7)
23212  fact = 1. + a(8)
23213  xk = pi/(2.*cl)
23214  za0 = xk*xa
23215  zam = za0*xm
23216  xam = xa*xm
23217  ! Bessel functions
23218  no = 0
23219  bi0 = bint(no, za0)
23220  bim = bint(no, zam)
23221  bi3 = bint(no, 3.*za0)
23222  bim3 = bint(no, 3.*zam)
23223  ! coefficients A10 and A30 (no dimensions)
23224  t10k = xm*xm*bi0 + bim
23225  t30k = xm*xm*bi3 + bim3
23226  zr0 = xk*r0
23227  zr3 = 3.*zr0
23228  bir0 = bint(no, zr0)
23229  bir3 = bint(no, 3.*zr3)
23230  alpk = 0.
23231  if (abs(bir3)/=6.*0.) alpk = bir0/bir3
23232  dtk = t10k + alpk*t30k/3.
23233  a10 = 0.
23234  if (abs(dtk)/=6.*0.) a10 = (xm*xm-1.)/dtk
23235  ! old E-cell is a even cell number (followed by a odd number standard cell
23236  ! old ncf=(nc/2)*2-nc
23237  ! old if(ncf.eq.0) a10=-a10
23238  a30 = -alpk*a10/3.
23239  ! cell limits x-vane y-vane
23240  cbx(nc) = r0
23241  bbx(nc) = (xm*xa-r0)/cl
23242  ablx(nc) = 0.
23243  cby(nc) = r0
23244  bby(nc) = (xa-r0)/cl
23245  ably(nc) = 0.
23246  ! conversion: cm --> m
23247  cbx(nc) = cbx(nc)*1.e-02
23248  cby(nc) = cby(nc)*1.e-02
23249  ! --- convert in units (MeV, m)
23250  ! rfq1(nc): A30 (no dimensions)
23251  ! rfq2(nc): A10 (no dimensions)
23252  ! rfq3(nc): cell length (m)
23253  ! rfq4(nc): phase RF (deg)
23254  ! rfq7(nc): mean aperture of the vane r0 (m)
23255  ! rfq9(nc): factor applied at the inter-vane potentiel
23256  ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
23257  ! rfq11(nc):intervane voltage applied to the particles (KV)
23258  rfq1(nc) = a30
23259  rfq2(nc) = a10
23260  rfq3(nc) = cl*1.e-02
23261  rfq4(nc) = phim
23262  rfq7(nc) = r0*1.e-02
23263  rfq9(nc) = fact
23264  rfq10(nc) = (1.+tvolt)*a(9)
23265  rfq11(nc) = (1.+avolt)*a(9)
23266  go to 50
23267  end if
23268  if (itype(nc)==3) then
23269  ! M-cell (ityp = 3)
23270  cl = a(1)
23271  xa = a(3)
23272  xm = a(4)
23273  r0 = a(5)
23274  phim = a(7)
23275  fact = 1. + a(8)
23276  ! cell limits x-vane = y-vane = average radius
23277  cbx(nc) = r0
23278  bbx(nc) = 0.
23279  ablx(nc) = 0.
23280  cby(nc) = r0
23281  bby(nc) = 0.
23282  ably(nc) = 0.
23283  ! conversion: cm --> m
23284  cbx(nc) = cbx(nc)*1.e-02
23285  cby(nc) = cby(nc)*1.e-02
23286  ! end vanes limits ******************************
23287  ! --- convert the parameters in units (MeV, m)
23288  ! rfq1(nc): A30 = 0
23289  ! rfq2(nc): A10 = 0
23290  ! rfq3(nc): cell length (m)
23291  ! rfq4(nc): phase RF (deg)
23292  ! rfq7(nc): mean aperture of the vane r0 (m)
23293  ! rfq9(nc): factor applied at the inter-vane potentiel(F = 1 + a(15))
23294  ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
23295  ! rfq11(nc):intervane voltage applied to the particles (KV)c
23296  rfq1(nc) = 0.
23297  rfq2(nc) = 0.
23298  rfq3(nc) = cl*1.e-02
23299  rfq4(nc) = phim
23300  rfq7(nc) = r0*1.e-02
23301  rfq9(nc) = fact
23302  rfq10(nc) = (1.+tvolt)*a(9)
23303  rfq11(nc) = (1.+avolt)*a(9)
23304  go to 50
23305  ! endif M-cell
23306  end if
23307  ! Fringe-field region after T-cell or M-cell (Type = 4)
23308  if (itype(nc)==4) then
23309  cl = a(1)
23310  a10 = a(2)
23311  xa = a(3)
23312  xm = a(4)
23313  r0 = a(5)
23314  rh0 = a(6)
23315  phim = a(7)
23316  fact = 1. + a(8)
23317  ! fringe field region limits
23318  cbx(nc) = r0*1.5
23319  bbx(nc) = 0.
23320  ablx(nc) = 0.
23321  cby(nc) = r0*1.5
23322  bby(nc) = 0.
23323  ably(nc) = 0.
23324  ! conversion: cm --> m
23325  cbx(nc) = cbx(nc)*1.e-02
23326  cby(nc) = cby(nc)*1.e-02
23327  ! end limits ******************************
23328  ! --- convert the parameters in units (MeV, m)
23329  ! rfq1(nc): A01 ( 1/(m*m) )
23330  ! rfq2(nc): A10 (no dimensions)
23331  ! rfq3(nc): cell length (m)
23332  ! rfq4(nc): phase RF (deg)
23333  ! rfq7(nc): mean aperture of the vane r0 (m)
23334  ! rfq9(nc): factor applied at the inter-vane potentiel (F = 1 + a(15))
23335  ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
23336  ! rfq11(nc):intervane voltage applied to the particles (KV)
23337  ! old rfq1(nc)=a01*1.e04
23338  rfq2(nc) = a10
23339  rfq3(nc) = cl*1.e-02
23340  rfq4(nc) = phim
23341  rfq7(nc) = r0*1.e-02
23342  rfq9(nc) = fact
23343  rfq10(nc) = (1.+tvolt)*a(9)
23344  rfq11(nc) = (1.+avolt)*a(9)
23345  end if
23346  ! ********************************************
23347  ! fringe field region the profil is read from disk
23348  if (itype(nc)==7) then
23349  ! read the ff profile in the form (z,R(z)) in M
23350  ! npt is the number of coordinates (z,R(z)
23351  open (67, file=fprof, status='unknown')
23352  ! read(67,*)npf
23353  npf = 0
23354  do
23355  read (67, *, end=888) xspf(npf+1), yspf(npf+1)
23356  npf = npf + 1
23357  end do
23358 888 write (16, *) 'RFQ FF from file with ', npf, ' data points'
23359  reca = xspf(1)
23360  do i = 1, npf
23361  xspf(i) = xspf(i) - reca
23362  end do
23363  ! length of the fringe field m
23364  cl = xspf(npf)
23365  call derif2(npf)
23366  phim = a(7)
23367  fact = 1. + a(8)
23368  write (16, *) 'Fringe Field length=', cl, ' m'
23369  write (16, *) 'Fringe Field Phase=', phim
23370  write (16, *) 'Fringe Field Field Factor=', fact
23371  ! --- limits x-vane y-vane
23372  cbx(nc) = 100.
23373  cby(nc) = 100.
23374  ablx(nc) = 0.
23375  ably(nc) = 0.
23376  bbx(nc) = 0.
23377  bby(nc) = 0.
23378  ! rfq1(nc) : not used
23379  ! rfq2(nc): not used
23380  ! rfq3(nc): Fringe field length (m)
23381  ! rfq4(nc): phase RF (deg)
23382  ! rfq7(nc): distance axe-vanes at the start of the FF (m)
23383  ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
23384  ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
23385  ! rfq11(nc):intervane voltage applied to the particles (KV)
23386  rfq1(nc) = 0.
23387  rfq2(nc) = 0.
23388  rfq3(nc) = cl
23389  rfq4(nc) = phim
23390  rfq7(nc) = r0
23391  rfq9(nc) = fact
23392  rfq10(nc) = (1.+tvolt)*a(9)
23393  rfq11(nc) = (1.+avolt)*a(9)
23394  close (67)
23395  ! cc write(16,579)nc,npt,cl,phim,r0,rfq10(nc),rfq11(nc)
23396  ! cc579 format(2(2x,i4),5(2x,e12.5))
23397  end if
23398  ! ********************************************
23399 60 continue
23400  if (netc<nceltot) then
23401  write (6, *) 'Error: Parameter NCELTOT after RFQPTQ entry in', ' DYNAC input file is ', nceltot
23402  write (6, *) 'This is larger than the', ' number of cells in the RFQ datafile, which is ', netc
23403  write (16, *) 'Error: Parameter NCELTOT after RFQPTQ entry in', ' DYNAC input file is ', nceltot
23404  write (16, *) 'This is larger than the', ' number of cells in the RFQ datafile, which is ', netc
23405  stop
23406  end if
23407  call rfq_parm
23408  return
23409  end subroutine cpardyn
23410  ! *******************************************************************
23411  ! function bint(n,z)
23412  ! --- integral representation of modified Bessel functions
23413  ! n integer order z argument
23414  ! *******************************************************************
23415  function bint(n, z)
23416  implicit real *8(a-h, o-z)
23417  common /consta/vl, pi, xmat, rpel, qst
23418  dimension ui(16), wi(16)
23419  ! GAUSS n=16 de -1. a 1
23420  data (ui(j), j=1, 16)/ -.9894009, -.9445750, -.8656312, -.7554044, -.6178762, -.4580168, -.2816036, -.0950125, &
23421  .0950125, .2816036, .4580168, .6178762, .7554044, .8656312, .9445750, .9894009/
23422  data (wi(j), j=1, 16)/.0271524, .0622535, .0951585, .1246288, .1495960, .1691565, .1826034, .1894506, .1894506, &
23423  .1826034, .1691565, .1495960, .1246288, .0951585, .0622535, .0271524/
23424 
23425  bint = 0.
23426  do i = 1, 16
23427  thet = pi/2.*(1.+ui(i))
23428  fln = float(n)
23429  cthet = cos(thet)
23430  fonc = exp(cthet*z)*cos(fln*thet)
23431  bint = bint + fonc*wi(i)
23432  end do
23433  bint = bint/2.
23434  return
23435  end function bint
23436  ! *******************************************************************
23437  ! SUBROUTINE accep_rfq(pib)
23438  ! Do so by shifting particles belonging to the same bunch from
23439  ! outside to inside (+/-) pi w.r.t.the synchronous particle
23440  ! *******************************************************************
23441  subroutine accep_rfq(pib)
23442  implicit real *8(a-h, o-z)
23443  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
23444  common /consta/vl, pi, xmat, rpel, qst
23445  common /faisc/f(10, iptsz), imax, ngood
23446  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
23447  common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
23448  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
23449  common /dyn/tref, vref
23450  common /mcs/imcs, ncstat, cstat(20)
23451  common /tapes/in, ifile, meta
23452  common /etcha3/ichxyz(iptsz)
23453  common /rec/irec
23454  common /etcom/cog(8), exten(17), fd(iptsz)
23455  logical chasit
23456  ! character*80 wfile
23457  do ite = 1, 3
23458  do i = 1, ngood
23459  drad = (f(6,i)-tref)*fh
23460  if (drad>pib) then
23461  ! old f(6,i)=(f(6,i)-pi/fh)
23462  f(6, i) = (f(6,i)-2.*pi/fh)
23463  end if
23464  if (drad<-pib) then
23465  ! old f(6,i)=(f(6,i)+pi/fh)
23466  f(6, i) = (f(6,i)+2.*pi/fh)
23467  end if
23468  end do
23469  end do
23470  tcog = 0.
23471  ! --- cog in time of bunch after reinjecting particles into the bunch
23472  do i = 1, ngood
23473  tcog = tcog + f(6, i)
23474  end do
23475  tcog = tcog/float(ngood)
23476  ! tref=tcog
23477  write (16, 59) tcog*fh*180./pi
23478 59 format (' Phase of COG after reinjecting particles into the ', 'bunch: ', e13.7, ' deg')
23479  return
23480  end subroutine accep_rfq
23481  ! *******************************************************************
23482  ! SUBROUTINE rfq_parm
23483  ! NOTE:
23484  ! The reference particle and particles may evolve separately or
23485  ! may be connected
23486  ! Only the SCHEFF space charge method is available
23487  ! Space charge computations are automaticaly made at the middle
23488  ! of each cell
23489  ! -------------------------------------------------------------------
23490  ! Radial matching section
23491  ! rfq1(nc): Aq (no dimension)
23492  ! rfq2(nc): not used
23493  ! rfq3(nc): RMS length (m)
23494  ! rfq4(nc): phase RF (deg)
23495  ! rfq7(nc): mean aperture of the vane r0 (m)
23496  ! rfq9(nc): factor to be applied at the inter-vane potentiel
23497  ! (only for particles)
23498  ! rfq10(nc):intervane voltage applied to the synchronous
23499  ! particle (KV)
23500  ! rfq11(nc):intervane voltage applied to the particles (KV)
23501 
23502  ! ---- standard accelerating cells (ityp = 0)
23503  ! rfq1(nc): A01 ( 1/(m*m) )
23504  ! rfq2(nc): A10 (no dimensions)
23505  ! rfq3(nc): cell length (m)
23506  ! rfq4(nc): phase RF (deg)
23507  ! rfq6(nc): A12 (no dimension)
23508  ! rfq7(nc): mean aperture of the vane r0 (m)
23509  ! rfq8(nc): A03 (1/(m**6)
23510  ! rfq9(nc): factor F = 1 + a() (only for inter-vane potentiel
23511  ! of particles)
23512  ! rfq10(nc):intervane voltage applied to the synchronous
23513  ! particle (KV)
23514  ! rfq11(nc):intervane voltage applied to the particles (KV)
23515  ! --- odds cells have a01 positive, even cells have a01 negative
23516 
23517  ! ---- transition T-cell and E-cell
23518  ! rfq1(nc): A30 (no dimensions)
23519  ! rfq2(nc): A10 (no dimensions)
23520  ! rfq3(nc): cell length (m)
23521  ! rfq4(nc): phase RF (deg)
23522  ! rfq7(nc): mean aperture of the vane r0 (m)
23523  ! rfq9(nc): factor F = 1 + a(8)
23524  ! rfq10(nc):intervane voltage applied to the synchronous
23525  ! particle (KV)
23526  ! rfq11(nc):intervane voltage applied to the particles (KV)
23527 
23528  ! ---- M-cell
23529  ! rfq1(nc): A30 = 0
23530  ! rfq2(nc): A10 = 0
23531  ! rfq3(nc): cell length (m)
23532  ! rfq4(nc): phase RF (deg)
23533  ! rfq7(nc): mean aperture of the vane r0 (m)
23534  ! rfq9(nc): factor F = 1 + a(8)
23535  ! rfq10(nc):intervane voltage applied to the synchronous
23536  ! particle (KV)
23537  ! rfq11(nc):intervane voltage applied to the particles (KV)
23538 
23539  ! ---- Fringe-field region from the potential function (F-cell)
23540  ! rfq1(nc): A01 ( 1/(m*m) )
23541  ! rfq2(nc): A10 (no dimensions)
23542  ! rfq3(nc): cell length (m)
23543  ! rfq4(nc): phase RF (deg)
23544  ! rfq7(nc): mean aperture of the vane r0 (m)
23545  ! rfq9(nc): factor F = 1 + a(8)
23546  ! rfq10(nc):intervane voltage applied to the synchronous
23547  ! particle (KV)
23548  ! rfq11(nc):intervane voltage applied to the particles (KV)
23549 
23550  ! ---- Fringe-field region the profil is read on the disk (F-cell)
23551  ! rfq1(nc): not used
23552  ! rfq2(nc): not used
23553  ! rfq3(nc): cell length (m)
23554  ! rfq4(nc): phase RF (deg)
23555  ! rfq7(nc): mean aperture of the vane r0 (m) (not used)
23556  ! rfq9(nc): factor F = 1 + a(8)
23557  ! rfq10(nc):intervane voltage applied to the synchronous
23558  ! particle (KV)
23559  ! rfq11(nc):intervane voltage applied to the particles (KV)
23560 
23561  ! *******************************************************************
23562  subroutine rfq_parm
23563  implicit real *8(a-h, o-z)
23564  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
23565  common /rigid/boro
23566  common /consta/vl, pi, xmat, rpel, qst
23567  common /dyn/tref, vref
23568  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
23569  common /faisc/f(10, iptsz), imax, ngood
23570  common /tapes/in, ifile, meta
23571  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
23572  common /etcom/cog(8), exten(17), fd(iptsz)
23573  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
23574  common /fene/wdisp, wphas, wx, wy, rlim, ifw
23575  common /dcspa/iesp
23576  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
23577  common /compt/nrres, nrtre, nrbunc, nrdbun
23578  common /shif/dtiph, shift
23579  common /femt/iemgrw, iemqesg
23580  common /posc/xpsc
23581  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
23582  ! common/drfq/p(9)
23583  common /azlist/icont, iprin
23584  common /trfq/icour, ncell
23585  logical iesp, ichaes, shift, iemgrw, iflag
23586  common /itvole/itvol, imamin
23587  common /tofev/ttvols
23588  common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
23589  common /rf2ptq/rfq1(500), rfq2(500), rfq3(500), rfq4(500), rfq6(500), rfq7(500), rfq8(500), rfq9(500)
23590  common /rf5ptq/tdvolt, rfq10(500), rfq11(500)
23591  ! old common/rfq3ptq/itype(500),evens,evenr
23592  common /rfq3ptq/itype(500), ipari(500), evens, evenr
23593  common /bonda/cbx(500), bbx(500), ablx(500), cby(500), bby(500), ably(500)
23594  logical itvol, imamin
23595  common /conti/irfqp
23596  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
23597  common /spff/xspf(400), yspf(400), sf(500), pf(500), qf(500)
23598  common /rms_prfl/npt, npf
23599  ! ********************************************
23600  ! v28/04/2015
23601  common /fcont/ifcont
23602  logical ifcont
23603  ! ********************************************
23604  ! logical irfqp,evens,evenr,evenf
23605  logical irfqp, evens, evenr
23606  dimension rfqdmp(500, 10)
23607  character *1 cr
23608  ! allow for print out on terminal of cell# on one and the same line
23609  cr = char(13)
23610  irfqp = .true.
23611  iflag = .false.
23612  radian = pi/180.
23613  ilost = 0
23614  twopi = 2.*pi
23615  ! convert vl in m
23616  vlm = vl/100.
23617  wavel = 2.*pi*vlm/fh
23618  er = xmat
23619  ! STATISTIQUES FOR PLOTS
23620  if (iprf==1) call stapl(davtot*10.)
23621  ! start prints in file 'short.data'
23622  tlgth = 0.
23623  idav = idav + 1
23624  iitem(idav) = 15
23625  dav1(idav, 9) = tdvolt*1000.
23626  dav1(idav, 7) = float(nceltot)
23627  dav1(idav, 8) = tdvolt*1000.
23628  ! --- end daves
23629  ! ns = 18: number of steps in cells (apart for the fringe field region and RMS)
23630  xlrfq = 0.
23631  ! the integer nn is only used if the RMS profile is required
23632  nn = 0
23633  do ncell = 1, nceltot
23634  write (6, 8254) nrtre, ncell, cr
23635 8254 format ('Transport element:', i5, ' RFQ cell :', i5, ' ', a1, $)
23636  ns = 18
23637  if (itype(ncell)==5) ns = 126
23638  if (itype(ncell)==6) ns = 126
23639  nsm = ns/2
23640  r0 = rfq7(ncell)
23641  cl = rfq3(ncell)
23642  davtot = davtot + cl*100.
23643  xlrfq = xlrfq + cl*100.
23644  if (itype(ncell)==0) then
23645  ! ------------- accelerating cells(ityp = 0)
23646  ! --- synchronous particle
23647  rtvolt = rfq10(ncell)
23648  vorsq = rfq1(ncell)*rtvolt
23649  av = rfq2(ncell)*rtvolt
23650  a12v = rfq6(ncell)*rtvolt
23651  ! --- particles
23652  pavolt = rfq11(ncell)
23653  vorb = rfq1(ncell)*pavolt*rfq9(ncell)
23654  avb = rfq2(ncell)*pavolt*rfq9(ncell)
23655  a12vb = rfq6(ncell)*pavolt*rfq9(ncell)
23656  a03vb = rfq8(ncell)*pavolt*rfq9(ncell)
23657  end if
23658  if (itype(ncell)==1) then
23659  ! ---------------- T-cell(Type = 1)
23660  ! ---- synchronous particle
23661  rtvolt = rfq10(ncell)
23662  a31v = rfq1(ncell)*rtvolt
23663  a10v = rfq2(ncell)*rtvolt
23664  ! ---- particles (field)
23665  pavolt = rfq11(ncell)
23666  a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
23667  av10b = rfq2(ncell)*pavolt*rfq9(ncell)
23668  end if
23669  if (itype(ncell)==2) then
23670  ! -------- E-cell(Type = 2)
23671  ! ---- synchronous particle
23672  rtvolt = rfq10(ncell)
23673  a31v = rfq1(ncell)*rtvolt
23674  a10v = rfq2(ncell)*rtvolt
23675  ! ---- particles
23676  pavolt = rfq11(ncell)
23677  a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
23678  a10vb = rfq2(ncell)*pavolt*rfq9(ncell)
23679  end if
23680  if (itype(ncell)==4) then
23681  ! -------, F-cell (ityp = 4)
23682  ! --- synchronous particle
23683  rtvolt = rfq10(ncell)
23684  av = rfq2(ncell)*rtvolt
23685  ! --- particles
23686  pavolt = rfq11(ncell)
23687  avb = rfq2(ncell)*pavolt*rfq9(ncell)
23688  end if
23689  ! ********************************************
23690  ! fringe field type 7
23691  if (itype(ncell)==7) then
23692  ! -------, F-cell (ityp = 7)
23693  ! --- synchronous particle
23694  rtvolt = rfq10(ncell)
23695  ! --- particles
23696  pavolt = rfq11(ncell)
23697  a31vb = pavolt*rfq9(ncell)
23698  end if
23699  ! ********************************************
23700  ! -----Radial matching section from potential function(Type = 5)
23701  if (itype(ncell)==5) then
23702  ! ---- synchronous particle
23703  rtvolt = rfq10(ncell)
23704  a31v = rfq1(ncell)*rtvolt
23705  a10v = rfq2(ncell)*rtvolt
23706  ! ---- particles (field)
23707  pavolt = rfq11(ncell)
23708  a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
23709  av10b = rfq2(ncell)*pavolt*rfq9(ncell)
23710  end if
23711  ! -----Radial matching section with vanes profile read from disk (Type = 6)
23712  if (itype(ncell)==6) then
23713  ! ---- potential applied to the synchronous particle
23714  rtvolt = rfq10(ncell)
23715  ! ---- potenatial applied to particles
23716  pavolt = rfq11(ncell)
23717  a31vb = pavolt*rfq9(ncell)
23718  end if
23719  ! c.o.g of the bunch
23720  tcog = 0.
23721  ecog = 0.
23722  do i = 1, ngood
23723  tcog = tcog + f(6, i)
23724  ecog = ecog + f(7, i)
23725  end do
23726  tcog = tcog/float(ngood)
23727  ecog = ecog/float(ngood)
23728  gcog = ecog/er
23729  bcog = sqrt(1.-1./(gcog*gcog))
23730  wcog = ecog - er
23731  if (ncell==1) then
23732  ! ---- shift = .false. ==> the synchronous particle is the center of gravity
23733  if (.not. shift) then
23734  tref = tcog
23735  bref = bcog
23736  vref = bref*vl
23737  gref = gcog
23738  wref = wcog
23739  wrefi = wref
23740  else
23741  ! ---- shift = .true. ==> the synchronous particle and the c.o.g are separated
23742  bref = vref/vl
23743  gref = 1./sqrt(1.-bref*bref)
23744  wref = er*(gref-1.)
23745  wrefi = wref
23746  end if
23747  end if
23748  ! --- standard accelerating cell (itype = 0)
23749  if (itype(ncell)==0) cay = pi/cl
23750  ! --- T-cell(itype = 1 , E-cell(itype = 2, fringe field region(itype = 4) RMS (itype = 5)
23751  if (itype(ncell)==1) cay = pi/(2.*cl)
23752  if (itype(ncell)==2) cay = pi/(2.*cl)
23753  if (itype(ncell)==5) cay = pi/(2.*cl)
23754  if (itype(ncell)==6) cay = pi/(2.*cl)
23755  ! --- fringe field region type 4
23756  if (itype(ncell)==4) then
23757  cay = pi/(2.*cl)
23758  ns = int(36.*cl/(bref*wavel))
23759  if (ns<=5) ns = 6
23760  nsm = ns/2
23761  end if
23762  ! ********************************************
23763  ! Fringe field region type 7
23764  if (itype(ncell)==7) then
23765  cay = pi/(2.*cl)
23766  ns = int(36.*cl/(bref*wavel))
23767  ns = 3*ns
23768  ! old if(ns.le.5) ns=6
23769  nsm = ns/2
23770  end if
23771  ! ********************************************
23772  ! --- M-cell (itype = 3)
23773  ! old sv if(itype(ncell).eq.3) cay=pi/cl
23774  xl = cl/float(ns)
23775  hl = .5*xl
23776  ! ---- scl: space charge length in SCHEFF unit (cm)
23777  scl = cl*100.
23778  ! ---- phini: phase of the synchronous at input of the cell
23779  phini = -tref*fh + rfq4(ncell)*radian
23780  if (ncell==1) then
23781  write (16, 178)
23782 178 format (/, ' Dynamics at the input', /, 5x, ' BETA GAMMA ENERGY(MeV) ', &
23783  ' TOF(deg) TOF(sec)')
23784  write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
23785 1788 format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
23786  write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
23787 165 format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
23788  write (16, *)
23789  write (75, 9627)
23790 9627 format (5x, 'ncell', 4x, 'A01(m-2)', 8x, 'A10', 12x, 'A12', 11x, 'r0(m)', 11x, 'A03(m-6)')
23791  write (70, 9977)
23792 9977 format (5x, 'ncell', 4x, 'Zcell(m)', 7x, 'Z(m)', 9x, 'Phi(deg)', 8x, 'Pho(deg)', 7x, 'Wsyn', 11x, 'Wcog', 9x, &
23793  'ngood')
23794  write (89, 9888)
23795 9888 format (4x, 'ncell', 1x, 'z(m) middle', 4x, 'phini(deg)', 5x, 'phmid(deg)')
23796  end if
23797  z = 0.
23798  ! ---- iterations over steps xl
23799  nsp1 = ns + 1
23800  do n = 1, nsp1
23801  z = z + hl
23802  if (z>cl) then
23803  zl = z - hl
23804  tlgth = tlgth + zl
23805  phfin = tref*fh + phini
23806  phfin = phfin*180./pi
23807  ! cc phfin=phref*180./pi
23808  if (ncell==1) then
23809  rfqdmp(ncell, 1) = zl
23810  else
23811  rfqdmp(ncell, 1) = zl + rfqdmp(ncell-1, 1)
23812  end if
23813  rfqdmp(ncell, 2) = phdep
23814  write (70, 9999) ncell, zl, tlgth, phdep, phfin, wref, wcog, ngood
23815 9999 format (2x, i5, 6(3x,e12.5), 3x, i6)
23816  go to 9527
23817  end if
23818  ! --- change of reference over the half step hl
23819  tref = tref + hl/(bref*vlm)
23820  if (itvol) ttvols = tref
23821  phref = tref*fh + phini
23822  skz = sin(cay*z)
23823  ckz = cos(cay*z)
23824  ! --- synchronous particle
23825  ! change of energy over the step xl
23826  sp = sin(phref)
23827  ! standard accelerating cell
23828  if (itype(ncell)==0) then
23829  dwref = .5*qst*cay*av*skz*sp*xl
23830  ! print in file rfq_list1.data
23831  if (n==1) phdep = rfq4(ncell)
23832  end if
23833  ! T-cell (type = 1)
23834  if (itype(ncell)==1) then
23835  skz3 = sin(3.*cay*z)
23836  ckz3 = cos(3.*cay*z)
23837  dwref = 0.5*qst*cay*(a10v*skz+3.*a31v*skz3)*sp*xl
23838  ! print in file rfq_list1.data
23839  if (n==1) phdep = rfq4(ncell)
23840  end if
23841  ! E-cell (type = 2)
23842  if (itype(ncell)==2) then
23843  skz3 = sin(3.*cay*z)
23844  ckz3 = cos(3.*cay*z)
23845  dwref = 0.5*qst*cay*(a10v*ckz+3.*a31v*ckz3)*sp*xl
23846  ! print in file rfq_list1.data
23847  if (n==1) phdep = rfq4(ncell)
23848  end if
23849  ! M-cell (type = 3)
23850  if (itype(ncell)==3) then
23851  dwref = 0.
23852  ! print in file rfq_list1.data
23853  if (n==1) phdep = rfq4(ncell)
23854  end if
23855  ! Fringe-field region (itype = 4)
23856  if (itype(ncell)==4) then
23857  rtvolt = rfq10(ncell)
23858  av = rfq2(ncell)*rtvolt
23859  c3kz = cos(3.*cay*z)
23860  skpz = .75*(skz+sin(3.*cay*z))
23861  dwref = .5*qst*cay*av*skpz*sp*xl
23862  ! print in file rfq_list1.data
23863  if (n==1) phdep = rfq4(ncell)
23864  end if
23865  ! ********************************************
23866  ! Fringe-field region (itype = 7)
23867  if (itype(ncell)==7) then
23868  dwref = 0.
23869  ! rprof: current fringe field profile at the azimutal position z
23870  c3kz = cos(3.*cay*z)
23871  rproff = splinf(npf, z)
23872  ! old write(16,*) 'FF z,radius ',z,rproff
23873  ! print in file rfq_list1.data
23874  if (n==1) phdep = rfq4(ncell)
23875  end if
23876  ! ********************************************
23877  ! --- RMS (type = 5)
23878  if (itype(ncell)==5) then
23879  dwref = 0.
23880  ! print in file rfq_list1.data
23881  if (n==1) phdep = rfq4(ncell)
23882  end if
23883  ! --- RMS (type = 6)
23884  if (itype(ncell)==6) then
23885  dwref = 0.
23886  ! rprof: current RMS profile given at z
23887  rprof = spline(npt, z)
23888  ! cc write(16,4527) n,z,rprof,a31vb
23889  ! cc4527 format(2x,i4,3(2x,e12.5))
23890  ! print in file rfq_list1.data
23891  if (n==1) phdep = rfq4(ncell)
23892  end if
23893  ! --- gain of energy (synchronous particle)
23894  wrefm = wref + 0.5*dwref
23895  grefm = wrefm/er + 1.
23896  brefm = sqrt(1.-1./(grefm*grefm))
23897  wref = wref + dwref
23898  gref = wref/er + 1.
23899  bref = sqrt(1.-1./(gref*gref))
23900  dez = 0.
23901  dref = 0.
23902  ! ---- Beam
23903  ! coordinates x, xp,y, yp convert in m and rad
23904  do ip = 1, ngood
23905  xi = f(2, ip)*1.e-02
23906  xpi = f(3, ip)*1.e-03
23907  yi = f(4, ip)*1.e-02
23908  ypi = f(5, ip)*1.e-03
23909  ww = f(7, ip) - er
23910  ! remove from the bunch particles that have energy < 0
23911  if (ww<0.) then
23912  f(8, ip) = 0.
23913  ilost = ilost + 1
23914  write (49, 5558) ip, ncell, ww
23915  iflag = .true.
23916  go to 6525
23917  end if
23918 5558 format (' particle: ', i5, ' cell: ', i5, ' energy: ', e12.5)
23919  gi = ww/er + 1.
23920  if (gi<1.) then
23921  f(8, ip) = 0.
23922  ilost = ilost + 1
23923  ! needs to be on energy
23924  write (49, *) ' particle lost: ', i, ' W: ', ww, ' MeV'
23925  iflag = .true.
23926  go to 6525
23927  end if
23928  bi = sqrt(1.-1./(gi*gi))
23929  bgi = bi*gi
23930  ! move particles back in the bunch if they have abs(phi) > pi
23931  tim = f(6, ip) + hl/(bi*vlm)
23932  phi = fh*(tim-tref)
23933  if (phi>=pi) then
23934  f(6, ip) = f(6, ip) - 2.*pi/fh
23935  tim = f(6, ip) + hl/(bi*vlm)
23936  phi = fh*(tim-tref)
23937  if (abs(phi)>pi) then
23938  f(8, ip) = 0.
23939  ilost = ilost + 1
23940  write (49, 5559) ip, ncell, phi, f(9, ip)
23941  iflag = .true.
23942  go to 6525
23943  end if
23944  end if
23945  if (phi<=-pi) then
23946  f(6, ip) = f(6, ip) + 2.*pi/fh
23947  tim = f(6, ip) + hl/(bi*vlm)
23948  phi = fh*(tim-tref)
23949  if (abs(phi)>pi) then
23950  f(8, ip) = 0.
23951  ilost = ilost + 1
23952  write (49, 5559) ip, ncell, phi, f(9, ip)
23953  iflag = .true.
23954  go to 6525
23955  end if
23956  end if
23957 5559 format (' particle: ', i5, ' cell: ', i5, ' phi(rad): ', e12.5, ' charge state ', f6.2)
23958  tim = f(6, ip) + hl/(bi*vlm)
23959  phi = phini + fh*tim
23960  qq = abs(f(9,ip))
23961  sp = sin(phi)
23962  cp = cos(phi)
23963  bav = bi
23964  gav = gi
23965  bgav = bgi
23966  bg = bgi
23967  beta = bi
23968  delt = 0.
23969  amort = 1.
23970  xm = xi + xpi*hl
23971  ym = yi + ypi*hl
23972  rm = sqrt(xm*xm+ym*ym)
23973  ! ---- particle is lost if abs(xm) > vanx or abs(ym) > vany
23974  if (n/=ns/2) then
23975  vanx = ablx(ncell)*z*z + bbx(ncell)*z + cbx(ncell)
23976  vany = ably(ncell)*z*z + bby(ncell)*z + cby(ncell)
23977  vanx = vanx*0.7523
23978  vany = vany*0.7523
23979  if (abs(xm)>=vanx) f(8, ip) = 0.
23980  if (abs(ym)>=vany) f(8, ip) = 0.
23981  if (f(8,ip)==0.) then
23982  ilost = ilost + 1
23983  write (49, 5556) ip, ncell, abs(xm), vanx, abs(ym), vany, rm
23984 5556 format (' particle: ', i5, ' cell: ', i5, ' abs(x) (m): ', e12.5, ' x-v(m): ', e12.5, ' abs(y) (m):', &
23985  e12.5, ' y-v(m): ', e12.5, ' radius (m) ', e12.5)
23986  iflag = .true.
23987  go to 6525
23988  end if
23989  end if
23990  if (n==ns/2) then
23991  if (rm>r0) then
23992  f(8, ip) = 0.
23993  ilost = ilost + 1
23994  write (49, 5557) ip, ncell, rm, r0
23995 5557 format (' particle: ', i5, ' cell: ', i5, ' radius (ptcl) (m): ', e12.5, ' radius (cell) (m):', e12.5)
23996  iflag = .true.
23997  go to 6525
23998  end if
23999  end if
24000  theta = 0.
24001  signx = 0.
24002  signy = 0.
24003  xml = xm
24004  yml = ym
24005  if (abs(xm)>1.e-10) then
24006  theta = atan(ym/xm)
24007  signx = 1.
24008  signy = 1.
24009  if (theta>0.) then
24010  if (xm<0.) signx = -1.
24011  if (ym<0.) signy = -1.
24012  end if
24013  if (theta<0.) then
24014  if (xm<0.) signx = -1.
24015  if (ym>0.) signy = -1.
24016  end if
24017  end if
24018  if (abs(xm)<=1.e-10) then
24019  if (abs(ym)>1.e-10) then
24020  if (xm>=0. .and. ym>0.) theta = pi/2
24021  if (xm>=0. .and. ym<0.) theta = -pi/2
24022  if (xm<0. .and. ym<0.) theta = pi/2
24023  if (xm<0. .and. ym>0.) theta = -pi/2
24024  end if
24025  end if
24026  if (theta==0.) then
24027  signx = 0.
24028  signy = 0.
24029  end if
24030  ! ---- standard accelerating cell
24031  if (itype(ncell)==0) then
24032  zrm = cay*rm
24033  ! ----- Bessel functions: I0 to I4
24034  bi0 = 1. + zrm*zrm/4. + zrm**4/64.
24035  ! old * +zrm**6/2304 +zrm**8/1.47456e05
24036  ! old bi0=bi0+zrm**10/1.47456e07
24037  ! old bi1=zrm/2.+zrm**3/16.+zrm**5/128.
24038  bi1 = zrm/2. + zrm**3/16.
24039  bi1p = 0.
24040  if (rm/=6.*0.) bi1p = bi1/rm
24041  bi3 = zrm**3/48. + zrm**5/768
24042  bi4 = zrm**4/384.
24043  bi4r = 0.
24044  if (rm>1.e-06) bi4r = bi4/rm
24045  bi5 = zrm**5/3840.
24046  c2t = cos(2.*theta)
24047  s2t = sin(2.*theta)
24048  c1t = cos(theta)
24049  s1t = sin(theta)
24050  ! --- transverse fields (cylindrical coordinates)
24051  erf = vorb*c2t*2.*rm + cay*(avb*bi1+a12vb*(bi3+bi5)*cos(4.*theta)/2.)*ckz
24052  erf = -erf/2.
24053  etf = vorb*s2t*2.*rm + 4.*a12vb*bi4r*sin(4.*theta)*ckz
24054  etf = etf/2.
24055  ! old sv evens=.false.
24056  ! old ncf=(ncell/2)*2-ncell
24057  ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24058  if (ncf==0) then
24059  erf = -erf
24060  etf = -etf
24061  ! old sv evens=.true.
24062  end if
24063  ! cartesian fields Ex and Ey
24064  ex = erf*c1t - etf*s1t
24065  ey = erf*s1t + etf*c1t
24066  ex = signx*ex
24067  ey = signy*ey
24068  end if
24069  ! ---- T-cell (Type = 1)
24070  if (itype(ncell)==1) then
24071  ! transverse fields (cylindrical coordinates)
24072  zrm = cay*rm
24073  zrm3 = zrm*3.
24074  bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
24075  ! old * +zrm**8/1.47456e05
24076  bi03 = 1. + zrm3*zrm3/4. + zrm3**4/64. + zrm3**6/2304.
24077  ! old * +zrm**8/1.47456e05
24078  bi1 = zrm/2. + zrm**3/16. + zrm**5/384.
24079  ! old bi1p=0.
24080  ! old if(rm.ne.6.*0.) bi1p=bi1/rm
24081  bi13 = zrm3/2. + zrm3**3/16. + zrm3**5/384.
24082  ! old bi13p=0.
24083  ! old if(rm.ne.6.*0.) bi13p=bi13/rm
24084  c2t = cos(2.*theta)
24085  s2t = sin(2.*theta)
24086  c1t = cos(theta)
24087  s1t = sin(theta)
24088  pavolt = rfq11(ncell)
24089  rpv = pavolt*rfq9(ncell)
24090  ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24091  if (ncf==0) then
24092  rpv = -rpv
24093  erf = -rpv/(r0*r0)*c2t*rm
24094  erf = erf + cay/2.*(av10b*bi1*ckz+3.*a31vb*bi13*ckz3)
24095  etf = rpv/(r0*r0)*s2t*rm
24096  else
24097  erf = -rpv/(r0*r0)*c2t*rm
24098  erf = erf - cay/2.*(av10b*bi1*ckz+3.*a31vb*bi13*ckz3)
24099  etf = rpv/(r0*r0)*s2t*rm
24100  end if
24101  ex = erf*c1t - etf*s1t
24102  ey = erf*s1t + etf*c1t
24103  ex = signx*ex
24104  ey = signy*ey
24105  end if
24106  ! tof over the length xl
24107  ! ---- E-cell (Type = 2)
24108  if (itype(ncell)==2) then
24109  ! --- transverse fields (cylindrical coordinates)
24110  zrm = cay*rm
24111  zrm3 = zrm*3.
24112  bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
24113  ! old * +zrm**8/1.47456e05
24114  bi03 = 1. + zrm3*zrm3/4. + zrm3**4/64. + zrm3**6/2304.
24115  ! old * +zrm**8/1.47456e05
24116  bi1 = zrm/2. + zrm**3/16. + zrm**5/384.
24117  ! old bi1p=0.
24118  ! old if(rm.ne.6.*0.) bi1p=bi1/rm
24119  bi13 = zrm3/2. + zrm3**3/16. + zrm3**5/384.
24120  ! old bi13p=0.
24121  ! old if(rm.ne.6.*0.) bi13p=bi13/rm
24122  c2t = cos(2.*theta)
24123  s2t = sin(2.*theta)
24124  c1t = cos(theta)
24125  s1t = sin(theta)
24126  pavolt = rfq11(ncell)
24127  rpv = pavolt*rfq9(ncell)
24128  erf = -rpv/(r0*r0)*c2t*rm
24129  ! *et*2015-07-07*s
24130  ! erf=erf+0.5*cay*(av10b*bi1*skz+3.*a31vb*bi13*skz3)
24131  erf = erf + 0.5*cay*(a10vb*bi1*skz+3.*a31vb*bi13*skz3)
24132  ! *et*2015-07-07*e
24133  etf = rpv/(r0*r0)*s2t*rm
24134  ! control polarity of the cell
24135  ! old ncf=(ncell/2)*2-ncell
24136  ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24137  if (ncf==0) then
24138  erf = -erf
24139  etf = -etf
24140  end if
24141  ex = erf*c1t - etf*s1t
24142  ey = erf*s1t + etf*c1t
24143  ex = signx*ex
24144  ey = signy*ey
24145  end if
24146  ! ---- M-cell (Type = 3)
24147  if (itype(ncell)==3) then
24148  c2t = cos(2.*theta)
24149  s2t = sin(2.*theta)
24150  c1t = cos(theta)
24151  s1t = sin(theta)
24152  pavolt = rfq11(ncell)
24153  rpv = pavolt*rfq9(ncell)
24154  erf = -rpv/(r0*r0)*c2t*rm
24155  etf = rpv/(r0*r0)*s2t*rm
24156  ! ---- M-cell (Type = 3)
24157  ! old if(itype(ncell).eq.3) then
24158  ! old c2t=cos(2.*theta)
24159  ! old s2t=sin(2.*theta)
24160  ! old c1t=cos(theta)
24161  ! old s1t=sin(theta)
24162  ! old pavolt=rfq11(ncell)
24163  ! old rpv=pavolt*rfq9(ncell)
24164  ! old erf=-rpv/(r0*r0)*c2t*rm
24165  ! old etf=rpv/(r0*r0)*s2t*rm
24166  ! old c3kz=cos(3.*cay*z)
24167  ! old erf=erf*(ckz+c3kz/3.)*0.75
24168  ! old etf=etf*(ckz+c3kz/3.)*0.75
24169  ! *************************************************
24170  ! control polarity of the cell
24171  ! old ncf=(ncell/2)*2-ncell
24172  ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24173  if (ncf==0) then
24174  erf = -erf
24175  etf = -etf
24176  end if
24177  ex = erf*c1t - etf*s1t
24178  ey = erf*s1t + etf*c1t
24179  ex = signx*ex
24180  ey = signy*ey
24181  end if
24182  ! ---- Radial matching section (type = 5)
24183  if (itype(ncell)==5) then
24184  c2t = cos(2.*theta)
24185  s2t = sin(2.*theta)
24186  c1t = cos(theta)
24187  s1t = sin(theta)
24188  skz3 = sin(3.*cay*z)
24189  ckz3 = cos(3.*cay*z)
24190  zrm = cay*rm
24191  b2kr = zrm*zrm/8.
24192  b2kr3 = (9./8.)*zrm*zrm
24193  qzrm = 0.
24194  erf = 0.
24195  etf = 0.
24196  if (rm>6*0.) then
24197  qzrm = (b2kr*skz-(1./27.)*b2kr3*skz3)
24198  erf = -1./8.*a31vb*cay*cay*(skz-1/3.*skz3)*c2t
24199  erf = erf*rm
24200  etf = a31vb*qzrm*s2t/rm
24201  end if
24202  ex = erf*c1t - etf*s1t
24203  ey = erf*s1t + etf*c1t
24204  ex = signx*ex
24205  ey = signy*ey
24206  end if
24207  ! ****************************************************
24208  if (itype(ncell)==6) then
24209  bgfac = gav*bav**2
24210  cc = a31vb*qq*xl*sp/(bgfac*er)
24211  rr1 = -cc/(rprof*rprof)
24212  rr2 = cc/(rprof*rprof)
24213  rr1 = rr1*xm
24214  rr2 = rr2*ym
24215  end if
24216  ! ********************************************
24217  ! Fringe field profil from the disk (type 7)
24218  if (itype(ncell)==7) then
24219  bgfac = gav*bav**2
24220  c1 = .75*(ckz+c3kz/3.)
24221  cc = a31vb*qq*xl*sp/(bgfac*er)
24222  rr1 = -cc/(rproff*rproff)
24223  rr2 = cc/(rproff*rproff)
24224  ! test the cell parity
24225  ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24226  if (ncf==0) then
24227  rr1 = -rr1
24228  rr2 = -rr2
24229  end if
24230  rr1 = rr1*xm
24231  rr2 = rr2*ym
24232  ! old if(ip.eq.25) write(16,5287)n,z,rproff,rr1/xm,rr2/ym
24233  ! 5287 format(2x,i4,4(2x,e12.5))
24234  end if
24235  ! ********************************************
24236  ! ---- CHANGE ENERGY OVER the STEP XL
24237  ! ------ standard accelerating cell or R-cell (Type = 0)
24238  if (itype(ncell)==0) then
24239  ez = 0.5*(avb*bi0+a12vb*bi4*cos(4.*theta))*skz*cay
24240  ! 2014 a12test line above replaced by line below
24241  ! ez=0.5*(avb*bi0)*skz*cay
24242  dw = qq*ez*sp*xl
24243  end if
24244  ! ------- T-cell (Type = 1)
24245  if (itype(ncell)==1) then
24246  ez = 0.5*cay*(av10b*skz*bi0+3.*a31vb*skz3*bi03)
24247  dw = qq*ez*sp*xl
24248  end if
24249  ! ------- E-cell (Type = 2)
24250  if (itype(ncell)==2) then
24251  ez = 0.5*cay*(a10vb*ckz*bi0+3.*a31vb*ckz3*bi03)
24252  dw = qq*ez*sp*xl
24253  end if
24254  ! ------- M-cell (itype = 3)
24255  if (itype(ncell)==3) dw = 0.
24256  ! ---- fringe field region (itype = 4)
24257  ! ********************************************
24258  if (itype(ncell)==4) dw = .5*qq*cay*avb*skz*sp*xl
24259  if (itype(ncell)==7) dw = 0.
24260  ! ********************************************
24261  ! --------RMS (itype = 5)
24262  if (itype(ncell)==5) then
24263  ez = -1./16.*a31vb*cay**3*rm*rm*(ckz-ckz3)*c2t
24264  dw = qq*ez*sp*xl
24265  end if
24266  ! --------RMS (itype = 6)
24267  if (itype(ncell)==6) then
24268  dw = 0.
24269  end if
24270  ! ---- WAV: energy at the middle of the element
24271  wav = ww + .5*dw
24272  ga = wav/er
24273  if (ga<=0.) then
24274  f(8, ip) = 0.
24275  ilost = ilost + 1
24276  ! needs to be on energy
24277  write (49, *) ' particle lost: ', i, ' W: ', wav, ' MeV'
24278  iflag = .true.
24279  go to 6525
24280  end if
24281  bgav = sqrt(ga*(2.+ga))
24282  gav = 1. + ga
24283  bav = bgav/gav
24284  ! ---- energy over step xl
24285  ww = ww + dw
24286  ga = ww/er
24287  gam = 1. + ga
24288  if (gam<=1.) then
24289  f(8, ip) = 0.
24290  ilost = ilost + 1
24291  ! needs to be on energy
24292  write (49, *) ' particle lost: ', i, ' W: ', ww, ' MeV'
24293  iflag = .true.
24294  go to 6525
24295  end if
24296  bg = sqrt(ga*(2.+ga))
24297  beta = sqrt(1.-1/(gam*gam))
24298  ! old jump of phase (sec) of particles (only for standard accelerating cells)
24299  delt = 0.
24300  ! old if(itype(ncell).eq.0) then
24301  ! old dez=.5*qq*cay*avb*skz*sp
24302  ! old delt=.5*(dez/er) * xl*xl/(bav**3*gav**3*vlm)
24303  ! old endif
24304  amort = bgi/bg
24305  bgfac = gav*bav**2
24306  cc = qq*xl*sp/(bgfac*er)
24307  ! ********************************************
24308  if (itype(ncell)/=4) then
24309  if (itype(ncell)==6) go to 9766
24310  if (itype(ncell)==7) go to 9766
24311  rr1 = cc*ex
24312  rr2 = cc*ey
24313 9766 continue
24314  xpm = xpi*amort + rr1
24315  ypm = ypi*amort + rr2
24316  xf = xm + xpm*hl
24317  yf = ym + ypm*hl
24318  end if
24319  ! ********************************************
24320  ! ------- Fringe-field region (itype = 4)
24321  if (itype(ncell)==4) then
24322  ! *********************************************************
24323  ! C1 = (1/m**2) * (m) = (1/m)
24324  ! C2 = (1/m**2) * (m) = (1/m)
24325  ! RF1 = (MeV/(MeV*m**2)) = (1/m**2)
24326  ! RF2 = (MeV/MeV) * (1/m**2) = (1/m**2)
24327  ! *******************************************************
24328  ! old RF1=QQ*VORB/ER
24329  ! old RF2=.25*QQ*CAY*CAY*AVB/ER
24330  ! old C1=RF1*SP*XL/BGFAC
24331  ! old C2=RF2*CKZ*SP*XL/BGFAC
24332  ! old C1=C1*.75*(CKZ+C3KZ/3.)
24333  ! old C2=C2*.75*(CKZ+3.*C3KZ)
24334  ! old RR1=-(C1+C2)
24335  ! old RR2=(C1-C2)
24336  ! rfq11(ncell) is (1.+avolt)*VV , where VV is intervane voltage seen by particles
24337  pavolt = rfq11(ncell)
24338  ! rfq9(ncell) is 1.+fvolt
24339  rpv = pavolt*rfq9(ncell)
24340  rf1 = qq*rpv/(r0*r0*er)
24341  ! avb is a10*rpv, but a10 is usually zero in fringe field
24342  rf2 = .25*qq*cay*cay*avb/er
24343  ! test cell parity
24344  ncf = (ipari(ncell)/2)*2 - ipari(ncell)
24345  if (ncf==0) then
24346  rf1 = -rf1
24347  rf2 = -rf2
24348  end if
24349  c1 = rf1*sp*xl/bgfac
24350  c2 = rf2*ckz*sp*xl/bgfac
24351  c1 = c1*.75*(ckz+c3kz/3.)
24352  c2 = c2*.75*(ckz+3.*c3kz)
24353  rr1 = -(c1+c2)
24354  rr2 = (c1-c2)
24355  xpm = xpi*amort + rr1*xm
24356  ypm = ypi*amort + rr2*ym
24357  xf = xm + xpm*hl
24358  yf = ym + ypm*hl
24359  end if
24360  ! restore coordinates x, xp, y, yp in cm and mrad
24361  f(2, ip) = xf*100.
24362  f(4, ip) = yf*100.
24363  f(3, ip) = xpm*1000.
24364  f(5, ip) = ypm*1000.
24365  ! tof over the length xl
24366  if (beta==0.) then
24367  f(6, ip) = f(6, ip) + hl/(bi*vlm)
24368  else
24369  f(6, ip) = f(6, ip) + hl/(bi*vlm) + hl/(beta*vlm)
24370  end if
24371  f(7, ip) = ww + er
24372 6525 continue
24373  ! --- end do ip (particle loop)
24374  end do
24375  ! ----- reshuffle the good particles at the end of each element
24376  if (iflag) then
24377  call shuffle
24378  iflag = .false.
24379  end if
24380  ! space charge at the middle of the cell
24381  if (n==nsm) then
24382  if (ichaes) then
24383  ! Space Charge
24384  iesp = .true.
24385  call cesp(scl)
24386  iesp = .false.
24387  end if
24388  end if
24389  ! --- change the reference over the half step hl
24390  tref = tref + hl/(bref*vlm)
24391  if (itvol) ttvols = tref
24392  vref = bref*vl
24393  z = z + hl
24394  ! print in file rfq_list1.phase RF in the middle of the cell
24395  if (n==ns/2) then
24396  phmil = tref*fh + phini
24397  phmil = phmil*180./pi
24398  write (89, 9735) ncell, z, phdep, phmil
24399 9735 format (2x, i5, 3(2x,e12.5))
24400  end if
24401  ! Change dp/p over the cell
24402  call disp
24403  ! end of do n=1,nsp1 (steps in cell)
24404  end do
24405 9527 continue
24406  ! ---- c.o.g of the bunch at the output of the cell
24407  tcog = 0.
24408  ecog = 0.
24409  do i = 1, ngood
24410  tcog = tcog + f(6, i)
24411  ecog = ecog + f(7, i)
24412  end do
24413  tcog = tcog/float(ngood)
24414  ecog = ecog/float(ngood)
24415  gcog = ecog/er
24416  bcog = sqrt(1.-1./(gcog*gcog))
24417  wcog = ecog - er
24418  ! --- window control relative to the energy of the c.o.g of the bunch
24419  ! ---- ifw = 0 ===> wdisp = dW/W
24420  ! ---- ifw = 1 ===> wdisp = dW (MeV)
24421  ! ----- convert wdisp in dp/p
24422  if (ifw==0 .or. ifw==10) then
24423  dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
24424  end if
24425  if (ifw==1 .or. ifw==11) then
24426  dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcog)
24427  end if
24428  iflag = .false.
24429  do i = 1, ngood
24430  dese = abs(fd(i)-1.)
24431  if (dese>dispr) then
24432  ilost = ilost + 1
24433  f(8, i) = 0.
24434  write (49, *) ' particle lost: ', i, ' dp/p: ', dese, ' window :', dispr
24435  iflag = .true.
24436  end if
24437  end do
24438  if (iflag) then
24439  call shuffle
24440  ! ---- c.o.g of the bunch after shuffle
24441  tcog = 0.
24442  ecog = 0.
24443  do i = 1, ngood
24444  tcog = tcog + f(6, i)
24445  ecog = ecog + f(7, i)
24446  end do
24447  tcog = tcog/float(ngood)
24448  ecog = ecog/float(ngood)
24449  gcog = ecog/er
24450  bcog = sqrt(1.-1./(gcog*gcog))
24451  wcog = ecog - er
24452  end if
24453  br0 = rfq7(ncell)*rfq7(ncell)
24454  bff = (1./er)*wavel*wavel*tdvolt/br0
24455  write (75, 5555) ncell, rfq1(ncell), rfq2(ncell), rfq6(ncell), rfq7(ncell), rfq8(ncell)
24456 5555 format (3x, i5, 5(3x,e12.5))
24457  ! et2010s
24458  ! dphete,dav1(idav,16),dav1(idav,21) and dav1(idav,12) still to be assigned correct value
24459  dphete = 0.
24460  trfprt = fh*tref*180./pi
24461  tcgprt = fh*tcog*180./pi
24462  ! n2kp=int(tofprt/360.)
24463  ! tofprt=tofprt-float(n2kp)*360.
24464  ! if(tofprt.gt.180.) tofprt=tofprt-360.
24465  ! cavity number, transmission (%), synchronous phase (deg), time of flight (deg) (reference),
24466  ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
24467  ! (MeV),
24468  ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
24469  ! longitudinal emittance (RMS, ns.keV)
24470  trnsms = 100.*float(ngood)/float(imax)
24471  call cdg(1)
24472  encog = cog(1)
24473  gcog = encog/xmat
24474  bcog = sqrt(1.-1./(gcog*gcog))
24475  tcog = cog(3)
24476  call ext2d(1)
24477  surxth = sqrt(exten(4)*exten(5)-exten(8)**2)
24478  suryph = sqrt(exten(6)*exten(7)-exten(9)**2)
24479  sqmdv = sqrt(exten(1)*exten(3)-exten(2)*exten(2))
24480  exns = bcog*surxth*10./sqrt(1.-bcog*bcog)
24481  eyns = bcog*suryph*10./sqrt(1.-bcog*bcog)
24482  emns = sqmdv*1.e12/fh
24483  if (ncell==1) then
24484  write (50, *) '# rfqparm.dmp'
24485  write (50, *) '# cell Z trans ', 'PHIs TOF(COG) COG Wcog TOF(REF) ', &
24486  ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS'
24487  write (50, *) '# # (m) (%) ', '(deg) (deg) beta (MeV) (deg) ', &
24488  ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)'
24489  end if
24490  write (50, 7023) ncell, rfqdmp(ncell, 1), trnsms, rfqdmp(ncell, 2), tcgprt, bcog, wcog, trfprt, bref, wref, &
24491  exns, eyns, emns
24492 7023 format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
24493  if (ncell==nceltot) then
24494  write (16, 179)
24495 179 format (/, ' Dynamics at the output', /, 5x, ' BETA GAMMA ENERGY(MeV) ', &
24496  ' TOF(deg) TOF(sec)')
24497  write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
24498  write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
24499  if (itvol) write (16, *) ' time of flight: ', ttvols*fh*180./pi, ' deg'
24500  ! ---- new magnetic rigidity of the reference
24501  xmor = xmat*bref*gref
24502  boro = 33.356*xmor*1.e-01/qst
24503  dav1(idav, 4) = davtot*10.
24504  dav1(idav, 5) = xlrfq*10.
24505  dav1(idav, 6) = (gref-1.)*er
24506  dav1(idav, 36) = ngood
24507  irfqp = .false.
24508  end if
24509  ! plots
24510  call stapl(davtot*10.)
24511  ! --- end do ncell
24512  end do
24513  call emiprt(0)
24514  ! v28/04/2015
24515  ifcont = .false.
24516  write (16, *) 'After RFQ, bunched beam assumed'
24517  return
24518  end subroutine rfq_parm
24519  ! *******************************************************************
24520  ! SUBROUTINE stripp
24521  ! --- solid stripper foils for 'slow' hadron particles
24522  ! *******************************************************************
24523  subroutine stripp
24524  implicit real *8(a-h, o-z)
24525  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
24526  common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
24527  common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
24528  common /mcs/imcs, ncstat, cstat(20)
24529  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
24530  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
24531  common /consta/vl, pi, xmat, rpel, qst
24532  common /qmoyen/qmoy
24533  common /rigid/boro
24534  common /faisc/f(10, iptsz), imax, ngood
24535  dimension pc(20), npcent(20)
24536  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
24537  ! dimension charge(6),pcent(6),charm(6),pc(6),eoff(6)
24538  character *1 cr
24539  dimension xeast(21), yeast(21), vecx(1)
24540  ! --- Eastham curve (reduced half angle over reduced thickness)
24541  ! ---- xeast: reduced thickness
24542  ! ---- yeast: reduced half angle
24543  data xeast/0.0, 2.0, 4.0, 6.0, 8.0, 10.0, 12.0, 14.0, 16.0, 18.0, 20.0, 22.0, 24.0, 26.0, 28.0, 30.0, 32.0, 34.0, &
24544  36.0, 38.0, 40.0/
24545  data yeast/0.00, 0.60, 1.04, 1.56, 1.80, 2.08, 2.32, 2.72, 2.96, 3.20, 3.44, 3.624, 3.808, 3.992, 4.176, 4.360, &
24546  4.544, 4.728, 4.912, 5.096, 5.28/
24547  ! ---- characteristics of the stripper:
24548  ! ---- qs : atomic number
24549  ! ---- atms : Atomic mass (amu)
24550  ! ---- ths:thickness (g/cm**2)
24551  ! allow for print out on terminal of stripper number on one and the same line
24552  cr = char(13)
24553  nstrp = 1
24554  imcs = 1
24555  write (6, 8254) nrtre, nstrp, cr
24556 8254 format ('Transport element:', i5, ' Charge Stripper :', i5, a1, $)
24557  write (16, 101) anp, atm
24558 101 format ('***** Projectile ', /, 4x, 'atomic number: ', f4.0, ' atomic mass : ', f4.0)
24559  write (16, 100) qs, atms, ths
24560 100 format ('***** Charge Stripper ', /, 4x, 'atomic number: ', f4.0, ' atomic mass : ', f4.0, ' thickness: ', e12.5, &
24561  ' g/cm**2')
24562  ! ---- characteristics of particles
24563  ! --------- qp=f(9,i)
24564  ! --------- uem: atomic mass (amu)
24565  ! --------- wp=f(7,i)-xmat
24566  ! ----------------------------
24567  ! ---- ENVELOPE
24568  if (iprf==1) call stapl(davtot*10.)
24569  ! ---- start prints in file 'short.data'
24570  idav = idav + 1
24571  iitem(idav) = 16
24572  dav1(idav, 1) = qs
24573  dav1(idav, 2) = atms
24574  dav1(idav, 3) = ths
24575  dav1(idav, 4) = davtot*10.
24576  ! ---- kinetic energy at the input
24577  wicg = 0.
24578  do i = 1, ngood
24579  wicg = f(7, i) + wicg
24580  end do
24581  wicg = wicg/float(ngood)
24582  gcog = wicg/xmat
24583  bcog = sqrt(gcog*gcog-1.)/gcog
24584  wicg = wicg - xmat
24585  np = 21
24586  denes = 0.
24587  do i = 1, np
24588  x(i) = xeast(i)
24589  y(i) = yeast(i)
24590  end do
24591  ! ---- deriv2: develop the matrix for the b-splines functions
24592  call deriv2(np)
24593  len = 1
24594  do ip = 1, ngood
24595  wp = f(7, ip) - xmat
24596  ! --- wpatm: MeV/atm
24597  wpatm = wp/atm
24598  qp = f(9, ip)
24599  ! ---- xa: screening distance (cm)
24600  qsp = qs**(2./3) + qp**(2./3)
24601  xa = 4.68165e-9/sqrt(qsp)
24602  ! ---- reduced thickness: thck
24603  xn = 6.022e23/atms
24604  thck = xn*pi*xa*xa*ths
24605  ! --- reduce half angle: rtheta(rad) from Eastham curve
24606  ! ---- b-splines interpollation if thck<40, otherwise: rthet = 9.2e-02*thck + 1.6 (linear interpolation)
24607  if (thck<40.) then
24608  rthet = spline(np, thck)
24609  else
24610  rthet = 9.2e-02*thck + 1.6
24611  end if
24612  ! ---- half angle of diffusion: dthet (mrad)
24613  zps = qs*qp/(xa*wp)
24614  dthet = 2.88e-10*zps*rthet
24615  ! --- angle of diffusion (mrad) scattered from M.C. separatly in xp and yp directions from a uniform law
24616  ! unif call rlux(vec,len)
24617  ! unif rx=(2.*vec-1.)*dthet*2.
24618  ! unif f(3,ip)=f(3,ip)+rx
24619  ! unif call rlux(vec,len)
24620  ! unif ry=(2.*vec-1.)*dthet*2.
24621  ! unif f(5,ip)=f(5,ip)+ry
24622  ! --- angle of diffusion (mrad) scattered from M.C. separatly in xp and yp directions from a Gaussian law
24623  ax = f(3, ip)
24624  sm = dthet*2.
24625  call randga(len, sm, ax, vx)
24626  f(3, ip) = vx
24627  ay = f(5, ip)
24628  call randga(len, sm, ay, vy)
24629  f(5, ip) = vy
24630  ! --- closest distance of approach: xb(cm)
24631  aps = (atms+atm)/(atms*atm)
24632  xb = 1.44e-13*aps*qs*qp/sqrt(wpatm)
24633  if (ip==1) then
24634  alpha = 1.576e-02*qp*qs/sqrt(wpatm)
24635  write (16, 5830) xa, thck, rthet, xb, dthet, alpha
24636 5830 format (4x, 'screening distance: ', e12.5, ' cm', /, 4x, 'reduced thickness: ', e12.5, &
24637  ' reduced half angle: ', e12.5, ' rad ', /, 4x, 'closest distance of approach: ', e12.5, ' cm', /, 4x, &
24638  'half angle of diffusion: ', e12.5, ' mrad', /, 4x, 'Bohr parameter: ', e12.5)
24639  end if
24640  ! ---- loss of energy per scatter in the stripper (eq.16)
24641  wapc = 4.*atm*atms/((atm+atms)**2)
24642  dene = wapc*xb*xb*rthet*rthet/(xa*xa)*wp
24643  denes = denes + dene
24644  f(7, ip) = f(7, ip) - dene
24645  ! ---- change the electric charge state of the particle over the foil
24646  f(9, ip) = qop
24647  end do
24648  denes = denes/float(ngood)
24649  write (16, *) 'dE(MeV) (Eastham): ', dene, denes
24650  if (qs==6. .or. qs==3.) then
24651  ! ---- change the electric charge state of the particles (carbon foil case)
24652  ! ---- Based on E.Baron et al, NIM A328 (1993) p.177-182
24653  ! calculate dX', dY', dZ'
24654  fksi = 0.1535375*(qs/atms)*anp*ths/(bcog*bcog)
24655  des = 0.5*0.001*(1.866+1.57*log(wicg/atm))*(anp/atm)
24656  des = des*sqrt(1000000.*ths*qs/atms)
24657  write (16, *) 'dE(MeV) stripping: ', des, des*atm, wicg, wicg/atm
24658  write (16, *) 'dE(MeV) ksi: ', fksi
24659  ! calculate the charge state distribution
24660  qbar = anp*(1.-exp(-83.275*bcog/(anp**0.447)))
24661  qavg = qbar*(1.-exp(-12.905+0.2124*anp-0.00122*anp*anp))
24662  yy = qbar/anp
24663  stdv = sqrt(qbar*(0.07535+0.19*yy-0.2654*yy*yy))
24664  con = 1./(stdv*sqrt(2.*pi))
24665  fact = -1./(2.*stdv*stdv)
24666  pcsum = 0.
24667  numchs = 0
24668  qst = int(qavg)
24669  ! ---- only take charge states that have more than thresh % of the particles
24670  thresh = 100./float(ngood)
24671  write (16, 7830) thresh
24672 7830 format (4x, 'Carbon foil stripper. Charge state distribution', &
24673  ' based on E.Baron et al, NIM A328 (1993) p.177-182', /, 4x, 'Threshhold for cutoff of the distribution: ', &
24674  f12.7, ' %')
24675  do i = 1, 100
24676  ! pc(i)=100.*con*exp(fact*(sqst(i)-qavg)*(sqst(i)-qavg))
24677  pcent = 100.*con*exp(fact*(float(i)-qavg)*(float(i)-qavg))
24678  if (pcent>thresh) then
24679  numchs = numchs + 1
24680  sqst(numchs) = float(i)
24681  pc(numchs) = pcent
24682  pcsum = pcsum + pcent
24683  end if
24684  end do
24685  nqst = numchs
24686  f(9, 1) = float(int(qavg))
24687  qavg = f(9, 1)
24688  write (16, 111) nqst, int(qavg)
24689  netac = nqst
24690 111 format (4x, 'Number of charge states after the foil ', i2, /, 4x, 'Average charge state: ', i3)
24691  ! FIRST TRAJECTORY HAS AVERAGE CHARGE STATE
24692  ntot = 0
24693  do i = 1, numchs
24694  npcent(i) = int(pc(i)*float(ngood)/100.)
24695  ntot = ntot + npcent(i)
24696  end do
24697  ! *temp*2012 : before correction
24698  do i = 1, numchs
24699  write (16, 122) sqst(i), npcent(i), pc(i)
24700  end do
24701  ! add missing number of particles to central charge state
24702  ncstat = numchs
24703  write (16, *) ' ntot,ngood=', ntot, ngood, ' particles'
24704  do i = 1, numchs
24705  if (int(sqst(i))==int(f(9,1))) then
24706  npcent(i) = npcent(i) + ngood - ntot
24707  end if
24708  cstat(i) = float(int(sqst(i)))
24709  charm(i) = cstat(i)
24710  write (16, 122) sqst(i), npcent(i), pc(i)
24711  end do
24712 122 format (4x, 'Charge=', f3.0, ' with ', i5, ' particles', ' or ', f12.7, ' %')
24713  len = 1
24714  i = 2
24715  do
24716  if (i>ngood) exit
24717  do
24718  call rlux(vecx, len)
24719  xarpha = vecx(1)
24720  ncount = int(xarpha*(float(numchs)+0.5))
24721  if (ncount>0) exit
24722  end do
24723  if (npcent(ncount)>0) then
24724  npcent(ncount) = npcent(ncount) - 1
24725  f(9, i) = float(int(sqst(ncount)))
24726  i = i + 1
24727  end if
24728  end do
24729  end if
24730  call cogetc
24731  ! ---- Change dp/p over the stripper
24732  call disp
24733 
24734  ! ---- the new reference is the cog
24735  qcg = 0.
24736  wcg = 0.
24737  do i = 1, ngood
24738  wcg = f(7, i) + wcg
24739  qcg = f(9, i) + qcg
24740  end do
24741  wcg = wcg/float(ngood)
24742  gcg = wcg/xmat
24743  qcg = qcg/float(ngood)
24744  qmoy = qcg
24745  bref = sqrt(gcg*gcg-1.)/gcg
24746  vref = bref*vl
24747  ! ---- new magnetic rigidity
24748  xmor = xmat*bref*gcg
24749  boro = 33.356*xmor*1.e-01/qcg
24750  diff = (wcg-xmat) - wicg
24751  dav1(idav, 5) = qavg
24752  dav1(idav, 6) = diff
24753  dav1(idav, 36) = ngood
24754  write (16, 5420) wicg, -diff
24755 5420 format (4x, 'energy of cog: at entrance: ', e12.5, ' MeV', /, 4x, 'energy loss of cog: ', e12.5, ' MeV')
24756  ! plots
24757  call stapl(davtot*10.)
24758  call emiprt(0)
24759  return
24760  end subroutine stripp
24761  subroutine randga(len, s, am, v)
24762  ! generateur aleatoire selon une loi normale
24763  ! s : ecart-type de la distribution
24764  ! am: moyenne de la distribution
24765  ! v : nombre aléatoire selon la loi normale
24766  implicit real *8(a-h, o-z)
24767  dimension vecx(1)
24768 
24769  a = 0.
24770  do i = 1, 24
24771  call rlux(vecx, len)
24772  y = vecx(1)
24773  a = a + y
24774  end do
24775  v = (a-12.)*s + am
24776  return
24777  end subroutine randga
24778  ! *******************************************************************
24779  ! SUBROUTINE qelec(volt,xlqua,rs)
24780  ! electrostatic quadrupole
24781  ! space charge computation at the middle of the lens
24782  ! VOLT: electric voltage at pole tip (kV)
24783  ! XLQUA: effective length (cm)
24784  ! RS: radial distance of pole tip from axis (cm)
24785  ! *******************************************************************
24786  subroutine qelec(volt, xlqua, rs)
24787  implicit real *8(a-h, o-z)
24788  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
24789  common /fene/wdisp, wphas, wx, wy, rlim, ifw
24790  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
24791  common /dyn/tref, vref
24792  common /consta/vl, pi, xmat, rpel, qst
24793  common /rigid/boro
24794  common /faisc/f(10, iptsz), imax, ngood
24795  common /etcom/cog(8), exten(17), fd(iptsz)
24796  common /qmoyen/qmoy
24797  common /dcspa/iesp
24798  logical iesp
24799  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
24800  logical ichaes
24801  common /tapes/in, ifile, meta
24802  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
24803  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
24804  common /shif/dtiph, shift
24805  logical shift
24806  common /compt/nrres, nrtre, nrbunc, nrdbun
24807  common /rander/ialin
24808  logical ialin
24809  common /qskew/qtwist, iqrand, itwist, iaqu
24810  logical itwist
24811  common /femt/iemgrw, iemqesg
24812  logical iemgrw
24813  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
24814  common /qsex/l, kq2, ks2
24815  common /tofev/ttvols
24816  common /itvole/itvol, imamin
24817  logical itvol, imamin
24818  real *8 l, kq2, ks2
24819  dimension trans(1)
24820  character *1 cr
24821 
24822  ilost = 0
24823  ! statistics
24824  if (iprf==1) call stapl(davtot*10.)
24825  write (16, *) ' ***QUADRUPOLE (electrostatic)***'
24826  write (16, *)
24827  fcpi = fh*180./pi
24828  if (itvol) write (16, 10) ttvols*fcpi, davtot
24829 10 format (' ** tof for adjustments at input: ', e12.5, ' deg at position: ', e12.5, ' cm in lattice')
24830  ! print out on terminal of transport element # on one and the same line
24831  nrtre = nrtre + 1
24832  cr = char(13)
24833  write (6, 8254) nrtre, nrres, cr
24834 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
24835  ! if itwist=.true. skews the quadrupole before misalignments (only if abs(volt) gt 1.e-13)
24836  ! len = 1 level 1 in rlux routine
24837  len = 1
24838  sqtwist = 0.
24839  if (abs(volt)>1.e-13) then
24840  if (itwist) then
24841  if (iqrand==0) then
24842  qtwrad = qtwist
24843  sqtwist = qtwrad
24844  call zrotat(qtwrad)
24845  else
24846  rdcf = .5
24847  call rlux(trans, len)
24848  if (trans(1)<=rdcf) sign = -1.
24849  if (trans(1)>rdcf) sign = 1.
24850  call rlux(trans, len)
24851  qtwrad = qtwist*sign*trans(1)
24852  sqtwist = qtwrad
24853  call zrotat(qtwrad)
24854  end if
24855  end if
24856  ! misalignments
24857  if (ialin) call randali
24858  end if
24859  idav = idav + 1
24860  iitem(idav) = 18
24861  dav1(idav, 1) = xlqua*10.
24862  davtot = davtot + xlqua
24863  dav1(idav, 4) = davtot*10.
24864  fh0 = fh/vl
24865  gpa = 0.
24866  do ii = 1, ngood
24867  gpa = gpa + f(7, ii)/xmat
24868  end do
24869  gpa = gpa/float(ngood)
24870  bet = sqrt(gpa*gpa-1.)/gpa
24871  l = xlqua
24872  eni = gpa*xmat
24873  qi = qst
24874  ! electric rigidity (kV)
24875  rigid = eni*bet*bet/qi*1.e03
24876  ! electric field gradient: xgrad (kV/cm-2)
24877  xgrad = 2.*volt/rs**2
24878  dav1(idav, 2) = volt
24879  dav1(idav, 3) = rigid
24880  dav1(idav, 5) = xgrad
24881  ! qk2 (cm-2)
24882  kq2 = xgrad/rigid
24883  dav1(idav, 6) = kq2
24884  dav1(idav, 7) = rs*10.
24885  write (16, 100) xlqua, rs, volt, kq2, xgrad, rigid
24886 100 format (' LENGTH = ', e12.5, ' cm APERTURE RADIUS= ', e12.5, ' cm', /, ' VOLTAGE = ', e12.5, ' kV K2 = ', &
24887  e12.5, ' cm-2 GRADIENT = ', e12.5, ' kV/cm2', /, ' RIGIDITY = ', e12.5, ' kV', /)
24888  call clear
24889  call elqua
24890  ! print out the transport matrix (cog)
24891  call matrix
24892  ! first half quadrupole
24893  l = xlqua/2.
24894  do ii = 1, ngood
24895  call clear
24896  gpa = f(7, ii)/xmat
24897  bet = sqrt(gpa*gpa-1.)/gpa
24898  qi = f(9, ii)
24899  ! electric rigidity (kV)
24900  rigi = f(7, ii)*bet*bet/qi*1.e03
24901  ! qk2 (cm-2)
24902  kq2 = xgrad/rigi
24903  call elqua
24904  call cobeam(ii, l)
24905  end do
24906  ! space charge computations (if l >0)
24907  if (ichaes .and. l>0.) then
24908  if (sce10==1 .or. sce10==3.) then
24909  iesp = .true.
24910  write (16, *) 'space charge at the middle of the lens'
24911  call cesp(xlqua)
24912  iesp = .false.
24913  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
24914  call disp
24915  end if
24916  end if
24917  ! Test window after the first half quadrupole (after s.c. computations)
24918  call cogetc
24919  bcour = 0.
24920  do i = 1, ngood
24921  gpai = f(7, i)/xmat
24922  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
24923  end do
24924  bcour = bcour/float(ngood)
24925  gcour = 1./sqrt(1.-bcour*bcour)
24926  wcg = (gcour-1.)*xmat
24927  ! ----- window control
24928  tref = tref + xlqua/(2.*vref)
24929  call reject(nlost)
24930  ! Reshuffles f(i,j) array after window (now done in 'reject')
24931  ! call shuffle
24932  ! second half quadrupole
24933  do ii = 1, ngood
24934  call clear
24935  gpa = f(7, ii)/xmat
24936  bet = sqrt(gpa*gpa-1.)/gpa
24937  qi = f(9, ii)
24938  rigi = f(7, ii)*bet*bet/qi*1.e03
24939  kq2 = xgrad/rigi
24940  call elqua
24941  call cobeam(ii, l)
24942  end do
24943  ! Test window after the second half quadrupole
24944  call cogetc
24945  tref = tref + xlqua/(2.*vref)
24946  call reject(ilost)
24947  ilost = ilost + nlost
24948  ! Reshuffles f(i,j) array after window (now done in 'reject')
24949  ! call shuffle
24950  ! Change the t.o.f
24951  if (itvol) ttvols = tref
24952  ! envelope
24953  call stapl(davtot*10.)
24954  tcog = 0.
24955  do i = 1, ngood
24956  tcog = tcog + f(6, i)
24957  end do
24958  tcog = tcog/float(ngood)
24959  if (itvol) then
24960  write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
24961 11 format (' ** tof for adjustments: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
24962  'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
24963  else
24964  write (16, 12) tref*fcpi, tcog*fcpi
24965 12 format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
24966  end if
24967  dav1(idav, 36) = ngood
24968  write (16, *) ' particles lost :', ilost
24969  ! returns coordinates to the initial orientation
24970  if (itwist) then
24971  if (abs(volt)>1.e-13) then
24972  qtwrad = -sqtwist
24973  call zrotat(qtwrad)
24974  end if
24975  end if
24976  if (iemgrw) call emiprt(0)
24977  ! envelope
24978  call stapl(davtot*10.)
24979  return
24980  end subroutine qelec
24981  ! *******************************************************************
24982  ! SUBROUTINE qfk (ityqu,arg,xlqua,rs)
24983  ! electrostatic or magnetic quadrupole based on the strength K2
24984  ! space charge computation at the middle of the lens
24985  ! ITYQU: ITYQU = 0 electric quadrupole, otherwise magnetic
24986  ! quadrupole
24987  ! ARG: strength K (cm-2)
24988  ! XLQUA: effective length (cm)
24989  ! RS: radial distance of pole tip from the axis (cm)
24990  ! *******************************************************************
24991  subroutine qfk(ityqu, arg, xlqua, rs)
24992  implicit real *8(a-h, o-z)
24993  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
24994  common /fene/wdisp, wphas, wx, wy, rlim, ifw
24995  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
24996  common /dyn/tref, vref
24997  common /consta/vl, pi, xmat, rpel, qst
24998  common /rigid/boro
24999  common /faisc/f(10, iptsz), imax, ngood
25000  common /etcom/cog(8), exten(17), fd(iptsz)
25001  common /qmoyen/qmoy
25002  common /dcspa/iesp
25003  logical iesp
25004  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
25005  logical ichaes
25006  common /tapes/in, ifile, meta
25007  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
25008  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
25009  common /shif/dtiph, shift
25010  logical shift
25011  common /compt/nrres, nrtre, nrbunc, nrdbun
25012  common /rander/ialin
25013  logical ialin
25014  common /qskew/qtwist, iqrand, itwist, iaqu
25015  logical itwist
25016  common /femt/iemgrw, iemqesg
25017  logical iemgrw
25018  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
25019  common /qsex/l, kq2, ks2
25020  common /tofev/ttvols
25021  common /itvole/itvol, imamin
25022  common /qfkd/ityq
25023  logical itvol, imamin, ityq
25024  real *8 l, kq2, ks2
25025  dimension trans(1)
25026  character *1 cr
25027 
25028  ilost = 0
25029  if (ityqu==0) ityq = .true.
25030  if (ityqu/=0) ityq = .false.
25031  if (ityq) then
25032  write (16, *) ' ***QUADRUPOLE (electrostatic)***'
25033  else
25034  write (16, *) ' ***QUADRUPOLE (magnetic)***'
25035  end if
25036  ! statistics
25037  if (iprf==1) call stapl(davtot*10.)
25038  xfqu = arg
25039  fcpi = fh*180./pi
25040  if (itvol) write (16, 10) ttvols*fcpi, davtot
25041 10 format (' ** tof at input: ', e12.5, ' deg position in the lattice: ', e12.5, ' cm ')
25042  ! print out on terminal of transport element # on one and the same line
25043  nrtre = nrtre + 1
25044  cr = char(13)
25045  write (6, 8254) nrtre, nrres, cr
25046 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
25047  ! if itwist=.true. skews the quadrupole before misalignments (only if abs(arg) gt 1.e-13)
25048  ! len = 1 level 1 in rlux routine
25049  len = 1
25050  sqtwist = 0.
25051  if (abs(xfqu)>1.e-13) then
25052  if (itwist) then
25053  if (iqrand==0) then
25054  qtwrad = qtwist
25055  sqtwist = qtwrad
25056  call zrotat(qtwrad)
25057  else
25058  rdcf = .5
25059  call rlux(trans, len)
25060  if (trans(1)<=rdcf) sign = -1.
25061  if (trans(1)>rdcf) sign = 1.
25062  call rlux(trans, len)
25063  qtwrad = qtwist*sign*trans(1)
25064  sqtwist = qtwrad
25065  call zrotat(qtwrad)
25066  end if
25067  end if
25068  ! misalignments
25069  if (ialin) call randali
25070  end if
25071  idav = idav + 1
25072  iitem(idav) = 19
25073  dav1(idav, 1) = xlqua*10.
25074  davtot = davtot + xlqua
25075  dav1(idav, 4) = davtot*10.
25076  fh0 = fh/vl
25077  gpa = 0.
25078  do ii = 1, ngood
25079  gpa = gpa + f(7, ii)/xmat
25080  end do
25081  gpa = gpa/float(ngood)
25082  bet = sqrt(gpa*gpa-1.)/gpa
25083  l = xlqua
25084  eni = gpa*xmat
25085  qi = qst
25086  ! electric quadrupole
25087  if (ityq) then
25088  ! rigid: electric momentum (kV)
25089  rigid = eni*bet*bet/qi*1.e03
25090  ! compute the electric voltage VOLT (kV) from K(cm-2)
25091  volt = xfqu*rs*rs*rigid
25092  volt = volt/2.
25093  ! kq2 (cm-2)
25094  kq2 = xfqu
25095  ! electric field gradient: xgrad (kV/cm2)
25096  xgrad = kq2*rigid
25097  dav1(idav, 2) = volt
25098  dav1(idav, 3) = rigid
25099  dav1(idav, 5) = xgrad
25100  dav1(idav, 6) = xfqu
25101  dav1(idav, 7) = rs*10.
25102  call clear
25103  call elqua
25104  write (16, 100) xlqua, rs, volt, xfqu, xgrad, rigid
25105 100 format (' LENGTH = ', e12.5, ' cm APERTURE RADIUS= ', e12.5, ' cm', /, ' VOLTAGE = ', e12.5, ' kV K2 = ', &
25106  e12.5, ' cm-2 GRADIENT = ', e12.5, ' kV/cm2', /, ' MOMENTUM = ', e12.5, ' kV', /)
25107  ! print the transport matrix (of the cog)
25108  call matrix
25109  end if
25110  ! magnetic quadrupole
25111  if (.not. ityq) then
25112  xmco = xmat*bet*gpa
25113  ! rigid: magnetic rigidity (kG.cm)
25114  rigid = 33.356*xmco*1.e-01/qst
25115  kq2 = xfqu
25116  ! bgrad: gradient (kG/cm)
25117  bgrad = kq2*rigid
25118  ! bgaus: field (kG)
25119  bgaus = bgrad*rs
25120  dav1(idav, 2) = bgaus
25121  dav1(idav, 3) = rigid
25122  dav1(idav, 5) = bgrad
25123  dav1(idav, 6) = xfqu
25124  dav1(idav, 7) = rs*10.
25125  call clear
25126  call elqua
25127  write (16, 3300) xlqua, rs, bgaus, xfqu, bgrad, rigid
25128 3300 format (' LENGTH = ', e12.5, ' cm APERTURE RADIUS= ', e12.5, ' cm', /, ' FIELD = ', e12.5, ' kG K2 = ', &
25129  e12.5, ' cm-2 GRADIENT = ', e12.5, ' kG/cm', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
25130  call matrix
25131  end if
25132  ! first half quadrupole
25133  l = xlqua/2.
25134  do ii = 1, ngood
25135  call clear
25136  gpa = f(7, ii)/xmat
25137  bet = sqrt(gpa*gpa-1.)/gpa
25138  qi = f(9, ii)
25139  ! electric quadrupole
25140  if (ityq) then
25141  ! rigi: momentum (kV)
25142  rigi = f(7, ii)*bet*bet/qi*1.e03
25143  ! qk2 (cm-2)
25144  kq2 = xgrad/rigi
25145  call elqua
25146  call cobeam(ii, l)
25147  end if
25148  ! magnetic quadrupole
25149  if (.not. ityq) then
25150  xmco = xmat*bet*gpa
25151  ! rigi: momentum (kG.cm)
25152  rigi = 3.3356*xmco/f(9, ii)
25153  ! kq2 (cm-2)
25154  kq2 = bgrad/rigi
25155  call elqua
25156  call cobeam(ii, l)
25157  end if
25158  end do
25159  ! space charge computations (if l >0)
25160  if (ichaes .and. l>0.) then
25161  if (sce10==1 .or. sce10==3.) then
25162  iesp = .true.
25163  write (16, *) 'space charge at the middle '
25164  call cesp(xlqua)
25165  iesp = .false.
25166  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
25167  call disp
25168  end if
25169  end if
25170  ! Test window after the first half quadrupole (after s.c. computations)
25171  call cogetc
25172  bcour = 0.
25173  do i = 1, ngood
25174  gpai = f(7, i)/xmat
25175  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
25176  end do
25177  bcour = bcour/float(ngood)
25178  gcour = 1./sqrt(1.-bcour*bcour)
25179  wcg = (gcour-1.)*xmat
25180  ! ----- convert window control
25181  tref = tref + xlqua/(2.*vref)
25182  call reject(nlost)
25183  ! Reshuffles f(i,j) array after window (now done in 'reject')
25184  ! call shuffle
25185  ! second half quadrupole
25186  do ii = 1, ngood
25187  call clear
25188  gpa = f(7, ii)/xmat
25189  bet = sqrt(gpa*gpa-1.)/gpa
25190  qi = f(9, ii)
25191  ! electric quadrupole
25192  if (ityq) then
25193  ! rigi (kV)
25194  rigi = f(7, ii)*bet*bet/qi*1.e03
25195  ! qk2 (cm-2)
25196  kq2 = xgrad/rigi
25197  call elqua
25198  call cobeam(ii, l)
25199  end if
25200  ! magnetic quadrupole
25201  if (.not. ityq) then
25202  xmco = xmat*bet*gpa
25203  ! rigi: momentum (kG.cm)
25204  rigi = 3.3356*xmco/f(9, ii)
25205  ! kq2 (cm-2)
25206  kq2 = bgrad/rigi
25207  call elqua
25208  call cobeam(ii, l)
25209  end if
25210  end do
25211  ! Test window after the second half quadrupole
25212  call cogetc
25213  tref = tref + xlqua/(2.*vref)
25214  call reject(ilost)
25215  ilost = ilost + nlost
25216  ! Reshuffles f(i,j) array after window (now done in 'reject')
25217  ! call shuffle
25218  ! Change the t.o.f
25219  if (itvol) ttvols = tref
25220  ! envelope
25221  call stapl(davtot*10.)
25222  tcog = 0.
25223  do i = 1, ngood
25224  tcog = tcog + f(6, i)
25225  end do
25226  tcog = tcog/float(ngood)
25227  if (itvol) then
25228  write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
25229 11 format (' ** tof for adjustments: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
25230  'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
25231  else
25232  write (16, 12) tref*fcpi, tcog*fcpi
25233 12 format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
25234  end if
25235  dav1(idav, 36) = ngood
25236  write (16, *) ' particles lost :', ilost
25237  ! returns coordinates to the initial orientation
25238  if (itwist) then
25239  if (abs(xfqu)>1.e-13) then
25240  qtwrad = -sqtwist
25241  call zrotat(qtwrad)
25242  end if
25243  end if
25244  if (iemgrw) call emiprt(0)
25245  ! envelope
25246  call stapl(davtot*10.)
25247  return
25248  end subroutine qfk
25249  ! *******************************************************************
25250  ! SUBROUTINE cavnum
25251  ! numerical computations of the dynamic in cavities or gap
25252  ! the field can be read on the disk on the form: (z,E(z)
25253  ! or it can be read in the command list on the form of a Fourier
25254  ! series expansion
25255  ! *******************************************************************
25256  subroutine cavnum
25257  implicit real *8(a-h, o-z)
25258  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
25259  common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
25260  fhpar, nc
25261  common /posi/ist
25262  common /midgap/enmil, vapmi
25263  common /azmtch/dlg, xmcph, xmce
25264  common /azlist/icont, iprin
25265  common /itvole/itvol, imamin
25266  common /func/a(200), ylg, atte, ncel, nharm
25267  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
25268  ! TRANSIT TIME COEFFICIENTS
25269  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25270  common /faisc/f(10, iptsz), imax, ngood
25271  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25272  common /cavnum1/xnh, xpas, ffield, npt
25273  common /cavnum2/b0, b1, b2, b3, b4, b5
25274  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
25275  common /rfield/ifield
25276  common /qmoyen/qmoy
25277  common /rigid/boro
25278  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
25279  common /consta/vl, pi, xmat, rpel, qst
25280  common /dyn/tref, vref
25281  common /compt/nrres, nrtre, nrbunc, nrdbun
25282  common /compt1/ndtl, ncavmc, ncavnm
25283  common /fene/wdisp, wphas, wx, wy, rlim, ifw
25284  common /tapes/in, ifile, meta
25285  common /etcom/cog(8), exten(17), fd(iptsz)
25286  common /speda/dave, idave
25287  common /shif/dtiph, shift
25288  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
25289  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
25290  common /dcspa/iesp
25291  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
25292  common /appel/irstay, ilost, iavp, ispcel
25293  common /femt/iemgrw, iemqesg
25294  common /mode/eflvl, rflvl
25295  common /aerp/vphase, vfield, ierpf
25296  common /tofev/ttvols
25297  common /elec/jelec
25298  common /step/istep
25299  ! ****************************************************************
25300  ! SV 09/09/2015
25301  common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
25302  common /kcell/avrg(15)
25303  ! ****************************************************************
25304  ! *ET*2015*Jul*S
25305  ! ********************************************
25306  ! reservation for TRACE3D related stuff
25307  common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
25308  common /t3dfld/fldctr(15), zend(15), t3d
25309  ! logical T3D,xiset
25310  logical t3d
25311  ! character*128 trace3h,trace3t,tif,tifa,tifb
25312  character *128 trace3h, trace3t, tif
25313  ! ********************************************
25314  common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
25315  ! *ET*2015*Jul*E
25316  logical iesp, ichaes, irstay, iavp, ispcel, ifield, iemgrw
25317  logical shift, chasit, itvol, imamin, dave, jelec
25318  character *1 cr
25319  ! ************************************************************
25320  ! XESLN : NEGATIVE LENGHT OF THE DRIFT FOLLOWING THE GAP
25321  ! IF XESLN N.E.0 THEN THE CHARGE SPACE EFFECT IMPLIES THE
25322  ! LENGTH (YLG-XESLN)
25323  nrres = nrres + 1
25324  ncavnm = ncavnm + 1
25325  ! allow for print out on terminal of gap# on one and the same line
25326  cr = char(13)
25327  write (6, 8254) nrtre, nrres, cr
25328 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
25329  write (16, *) ' CAVITY N :', nrres
25330  ilost = 0
25331  aqst = abs(qst)
25332  qmoy = aqst
25333  ! --- the frequency fh may be changed with delfh
25334  oldfh = fh
25335  ! IDUM : dummy variable (indicate in input file the number of the cavity)
25336  read (in, *) idum
25337 
25338  ! ielec = 0 acceleration for non relativistic particles with erest < 1 MeV (e.g. non-relativistic electrons)
25339  ! otherwise acceleration for hadrons
25340  ! dphase (deg): phase offset from the phase crest (giving the maximum of energy gain)
25341  ! FFIELD : in percent;
25342  ! (electric field)=(initial electric field)*(1.+FFIELD/100)
25343  jelec = .false.
25344  read (in, *) dielec, dphase, ffield, istep, ielec
25345  ! *********************************************************
25346  ! SV 28/10/2015
25347  if (ncavnm==1) write (13, 990)
25348 990 format (3x, 'ncav', 2x, 'ncell', 2x, 'pos I(cm)', 4x, 'pos S(cm)', 6x, 'L cell(cm)', 5x, 'W(Mev)', 7x, 'dw(Mev)', &
25349  6x, 'TOF(dg)', 7x, 'Ph RF(dg)', 5x, 'avrg pos(cm)')
25350  if (ncavnm==1) write (13, 995)
25351 995 format (3x, 'ncell', 3x, 'E0TL(Mev)', 4x, 'T(k) Mev/q', 4x, 'S(k) Mev/q', 5x, 'dW(Mev)', 6x, 'PHASE(dg)', 5x, &
25352  'Ph crest(dg)')
25353  write (13, *)
25354  ! ***************************************************************
25355  if (ielec==0) jelec = .true.
25356  ffield = 1. + ffield/100.
25357  if (ffield==0.) ffield = 1.e-12
25358  if (ifield) then
25359  ! --- The field is read on the disk in the form:
25360  ! z (cm) E(z) MV/cm
25361  ! fhc: frequency of the cavity (Hertz) (read in the file 'field.txt' )
25362  fh = fhc*2.*pi
25363  ncel = ncell
25364  atte = att
25365  ye0 = atte
25366  ! flength : length of the field (cm)
25367  flength = xspl(npt) - xspl(1)
25368  ylg = flength
25369  else
25370  ! --- The field is read on the input list in the form of a Fourier series
25371  ncell = ncel
25372  oldfh = fh
25373  ! atte: factor acting on the amplitude of the field (read in the input list)
25374  ye0 = atte
25375  end if
25376  dphete = dphase
25377  if (itvol .and. imamin) then
25378  ! --- adjustment of the phase offset w.r.t. the t.o.f. (deg)
25379  ottvol = fh*ttvols*180./pi
25380  attvol = ottvol
25381  xkpi = ottvol/360.
25382  ixkpi = int(xkpi)
25383  xkpi = (xkpi-float(ixkpi))*360.
25384  dphase = dphase - xkpi
25385  end if
25386  write (16, 150) fh/(2.*pi), ylg, atte, ffield, ncel, istep
25387 150 format (4x, 'FREQUENCY :', e12.5, ' Hertz', /, 4x, 'FIELD LENGTH :', e12.5, ' cm', /, 4x, &
25388  'FIELD FACTOR (UNITS CONVERSION) :', e12.5, /, 4x, 'FIELD FACTOR (ATTENUATION) :', e12.5, /, 4x, &
25389  'FIELD DIVIDED IN: ', i4, ' CELLS STEPS BY CELL ', i5)
25390  if (.not. imamin) write (16, *) ' PHASE OFFSET: ', dphete, ' DEG'
25391  if (imamin) write (16, 1501) dphete, dphase, xkpi
25392 1501 format (4x, 'PHASE OFFSET (before adjustment): ', e12.5, ' deg', /, 4x, 'PHASE OFFSET (after adjustment): ', &
25393  e12.5, ' deg', /, 4x, 'ADJUSTMENT ON THE PHASE OFFSET: ', e12.5, ' deg')
25394  fh0 = fh/vl
25395  beref = vref/vl
25396  ! --- ttvol: time of flight at entrance (sec)
25397  ttvol = 0.
25398  if (itvol) ttvol = ttvols*fh
25399  ! start file 'short.data'
25400  ! --- dav1(idav,3)=0: the particle reference and the cog coincide at the input
25401  ! --- dav1(idav,3)=1: the particle reference and the cog are independent
25402  dav1(idav, 3) = 0.
25403  idav = idav + 1
25404  iitem(idav) = 1
25405  dav1(idav, 1) = ylg*10.
25406  dav1(idav, 2) = ye0*100.
25407  davtot = davtot + ylg
25408  dav1(idav, 24) = davtot*10.
25409  dav1(idav, 40) = fh
25410  if (iprf==1) call stapl(dav1(idav,24))
25411  iarg = 1
25412  call cdg(iarg)
25413  enold = cog(1)
25414  encog = enold
25415  gcog = enold/xmat
25416  bcog = sqrt(1.-1./(gcog*gcog))
25417  tcog = cog(3)
25418  if (shift) then
25419  ! --- the reference particle and the cog are independent
25420  beref = vref/vl
25421  gamref = 1./sqrt(1.-(beref*beref))
25422  enref = xmat*gamref
25423  trefdg = tref*fh*180./pi
25424  dav1(idav, 3) = 1.
25425  else
25426  ! --- the reference particle and the cog are coinciding
25427  beref = bcog
25428  vref = bcog*vl
25429  tref = tcog
25430  gamref = gcog
25431  enref = cog(1)
25432  dav1(idav, 3) = 0.
25433  end if
25434  if (dav1(idav,3)==1.) write (16, *) ' ****reference and cog evolve independently'
25435  if (dav1(idav,3)==0.) write (16, *) ' **** the reference is the cog '
25436  write (16, 178)
25437 178 format (/, ' Dynamics at the input', /, 5x, ' BETA GAMMA ENERGY(MeV) ', ' TOF(deg) TOF(sec)')
25438  write (16, 1788) bcog, gcog, encog - xmat, tcog*fh*180./pi, tcog
25439 1788 format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
25440  enrprin = enref - xmat
25441  write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
25442 165 format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
25443  iprint = 0
25444  call statis
25445  xk1 = fh/vref
25446  ! --- transit time factors TK and SK based on the velocity at the entrance
25447  tk = tta0(beref)/2.*ffield
25448  sk = tsb0(beref)/2.*ffield
25449  ! --- prediction of PCREST (phase of RF giving the maximum of energy gain in the cavity)
25450  pcrest = atan(-sk/tk)
25451  ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
25452  if (ddwc<0.) pcrest = pcrest + pi
25453  ! --- first correction of pcrest based on an average beta
25454  call phcrest(pcrest, ylg, ncell, zcrest)
25455  ! avbet: average value of beta
25456  avbet = fh/(zcrest*vl)
25457  tk = tta0(avbet)/2.*ffield
25458  sk = tsb0(avbet)/2.*ffield
25459  pcrest = atan(-sk/tk)
25460  ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
25461  if (ddwc<0.) pcrest = pcrest + pi
25462  ! final correction of the phase crest PCREST
25463  call phcrest1(pcrest, ylg, ncell)
25464  ! phase at the entrance of the cavity
25465  dphase = dphase*pi/180.
25466  phi0 = pcrest + dphase + ttvol
25467  ! --- compute energy and TOF of reference
25468  ! ******************************************
25469  call dwref(phi0, gams, ts)
25470  ! ********************************************
25471  enrs = gams*xmat
25472  ddw = enrs - enref
25473  if (t3d) then
25474  do klm = 1, ncel
25475 
25476  trphase = tr3ph(klm)
25477  tre0tl = t0tr3d(klm)/aqst
25478  ! c split cell into drif-gap-drift
25479  ! c debugging to be done: include q/m !!! protons assumed for now
25480  kt3t = kt3t + 1
25481  ! drift
25482  write (tif, 6001) kt3t, kt3t, 10.*fldctr(klm)
25483 6001 format (' nt(', i4, ')= 1, a(1,', i4, ')=', f12.6)
25484  trace3t(kt3t) = tif
25485 
25486  kt3t = kt3t + 1
25487  ! gap
25488  write (tif, 6005) kt3t, kt3t, tre0tl, trphase, fid
25489 6005 format (' nt(', i4, ')=10, a(1,', i4, ')=', f9.5, ' , ', f9.2, ', 0., 1.,', f5.3, ',')
25490  trace3t(kt3t) = tif
25491 
25492  kt3t = kt3t + 1
25493  ! drift
25494  write (tif, 6001) kt3t, kt3t, 10.*zend(klm)
25495  trace3t(kt3t) = tif
25496  end do
25497  end if
25498  ! end trace3d drift-gap-drift
25499 
25500  trefs = ts + tref
25501  bets = sqrt(gams*gams-1.)/gams
25502  ! old bets=b5
25503  tredg = fh*trefs*180./pi
25504  ! dynamic of the bunch
25505  call bcnum(phi0, ylg, ncell)
25506  ! ----- window control
25507  gcg = 0.
25508  do i = 1, ngood
25509  gcg = gcg + f(7, i)/xmat
25510  end do
25511  gcg = gcg/float(ngood)
25512  bcg = sqrt(1.-1./(gcg*gcg))
25513  wcg = (gcg-1.)*xmat
25514  call cogetc
25515  ! omment twind=0.
25516  do i = 1, ngood
25517  gpai = f(7, i)/xmat
25518  if (gpai<1.) gpai = 1.
25519  bpai = sqrt(1.-1./(gpai*gpai))
25520  fd(i) = bpai/bcg*gpai/gcg
25521  ! omment twind=twind+f(6,i)
25522  end do
25523  ! omment twind=twind/float(ngood)
25524  ! ---- window control
25525  tref = trefs
25526  vref = bets*vl
25527  call reject(ilost)
25528  ! Reshuffles f(i,j) array after window (now done in 'reject')
25529  ! call shuffle
25530  write (16, *) ' PARAMETERS RELATING TO THE REFERENCE PARTICLE '
25531  write (16, *) '***********************************************'
25532  write (16, *) ' ENERGY GAIN(MeV) ', ddw, ' TOF ', tredg, ' DEG'
25533  write (16, *) ' PHASE OF RF AT ENTRANCE(DG) ', phi0*180./pi
25534  write (16, *) ' CREST PHASE OF RF (DEG) ', pcrest*180./pi
25535  iarg = 1
25536  call cdg(iarg)
25537  encog = cog(1)
25538  gcog = encog/xmat
25539  bcog = sqrt(1.-1./(gcog*gcog))
25540  tcog = cog(3)
25541  call ext2d(1)
25542  ! print in file 'short.data'
25543  ! 3.12.09 phnew=-(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
25544  ! 3.12.09 dav1(idav,6)=encog-xmat
25545  ! 3.12.09 dav1(idav,7)=phnew
25546  if (itvol) then
25547  dav1(idav, 38) = dphete
25548  dav1(idav, 39) = dphase*180./pi
25549  else
25550  dav1(idav, 38) = dphete
25551  end if
25552  write (16, 3777)
25553 3777 format (/, ' Dynamics at the output', /, 5x, ' BETA dW(MeV) ENERGY(MeV) ', ' TOF(deg) TOF(sec)')
25554  engain = encog - enold
25555  write (16, 3473) bets, ddw, enrs - xmat, fh*trefs*180./pi, trefs
25556 3473 format (' REF ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
25557  write (16, 1789) bcog, engain, encog - xmat, tcog*fh*180./pi, tcog
25558 1789 format (' COG ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
25559  testca = exten(1)*exten(2)*exten(3)
25560  ! epsil=1.E-20
25561  epsil = 1.e-40
25562  if (abs(testca)>epsil) then
25563  qdisp = 2.*sqrt(exten(1))
25564  qmd = exten(1)*exten(3) - exten(2)**2
25565  sqmdv = 4.*pi*sqrt(qmd)
25566  surm = 4.*pi*sqrt(qmd)*180./pi
25567  qdp = 2.*sqrt(exten(3))
25568  cor12 = exten(2)/sqrt(exten(1)*exten(3))
25569  ! omment PENT12=SQRT(exten(1)/exten(3))/COR12
25570  ! omment PENT21=SQRT(exten(1)/exten(3))*COR12
25571  qdpde = qdp*180./pi
25572  else
25573  qdisp = 0.
25574  qmd = 0.
25575  sqmdv = 0.
25576  surm = 0.
25577  qdp = 0.
25578  cor12 = 0.
25579  pent12 = 0.
25580  pent21 = 0.
25581  qdpde = 0.
25582  end if
25583  trqtx = exten(4)*exten(5) - exten(8)**2
25584  trqpy = exten(6)*exten(7) - exten(9)**2
25585  qditax = 2.*sqrt(exten(4))
25586  qdiant = 2.*sqrt(exten(5))
25587  qditay = 2.*sqrt(exten(6))
25588  qdianp = 2.*sqrt(exten(7))
25589  surxth = 4.*pi*sqrt(trqtx)
25590  suryph = 4.*pi*sqrt(trqpy)
25591  if (shift) then
25592  vref = bets*vl
25593  tref = trefs
25594  else
25595  vref = bcog*vl
25596  tref = tcog
25597  end if
25598  if (itvol) ttvols = tref
25599  call statis
25600  ! ENVEL
25601  call stapl(dav1(idav,24))
25602  ! old WRITE(16,9998) SQMDV
25603  ! old 9998 FORMAT(2X,' EMITTANCE (norm): ',
25604  ! old * E12.5,' PI*MEV*RAD')
25605  dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
25606  ! 3.12.09 dav1(idav,17)=surxth*10./pi
25607 
25608  dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
25609  dav1(idav, 25) = nrres
25610  dav1(idav, 30) = ngood
25611 
25612  ! print in the file: 'dynac.dmp':
25613  ! gap number, phase offset(deg), relativistic beta, energy(MeV), horz. emit.(mm*mrd,norm), vert.
25614  ! emit.(mm*mrd,norm),long. emit(keV*sec)
25615 
25616  ! --- dav1(idav,16): Emittance(norm) x-xp (mm*mrad)
25617  ! --- dav1(idav,21): Emittance(norm) y-yp (mm*mrad)
25618  emns = 1.e12*sqmdv/(pi*fh)
25619  ! et2010s
25620  trfprt = fh*tref*180./pi
25621  tcgprt = fh*tcog*180./pi
25622  ! TEST n2kp=int(tofprt/360.)
25623  ! TEST tofprt=tofprt-float(n2kp)*360.
25624  ! TEST if(tofprt.gt.180.) tofprt=tofprt-360.
25625  ! cavity number, z (m), transmission (%), synchronous phase (deg), time of flight (deg) (within –180 deg and 180
25626  ! deg),
25627  ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
25628  ! (MeV),
25629  ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
25630  ! longitudinal emittance (RMS, ns.keV)
25631  trnsms = 100.*float(ngood)/float(imax)
25632  if (ncavnm==1) write (50, *) '# cavnum.dmp'
25633  if (ncavnm==1) write (50, *) '# cav Z trans ', &
25634  'PHIs TOF(COG) COG Wcog TOF(REF) ', &
25635  ' REF Wref Ex,RMS,n Ey,RMS,n El,RMS'
25636  if (ncavnm==1) write (50, *) '# # (m) (%) ', &
25637  '(deg) (deg) beta (MeV) (deg) ', &
25638  ' beta (MeV) (mm.mrad) (mm.mrad) (ns.keV)'
25639  write (50, 7023) nrres, 0.001*dav1(idav, 24), trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, &
25640  enrs - xmat, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
25641 7023 format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
25642  ! et2010e
25643  fh = oldfh
25644  ! new magnetic rigidity of the reference
25645  gref = 1./sqrt(1.-bets*bets)
25646  xmor = xmat*bets*gref
25647  boro = 33.356*xmor*1.e-01/aqst
25648  write (16, *) ilost, ' particles lost in cavity ', nrres
25649  call emiprt(0)
25650  return
25651  end subroutine cavnum
25652  ! *******************************************************************
25653  ! SUBROUTINE phcrest(phi0,ylg,ncell,zcrest)
25654  ! REFERENCE:
25655  ! average k (cm-1)
25656  ! *******************************************************************
25657  subroutine phcrest(phi0, ylg, ncell, zcrest)
25658  implicit real *8(a-h, o-z)
25659  common /cavnum1/xnh, xpas, fmult, npt
25660  common /cavnum2/b0, b1, b2, b3, b4, b5
25661  common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
25662  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
25663  common /consta/vl, pi, xmat, rpel, qst
25664  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25665  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25666  common /dyn/tref, vref
25667  ! ylg(cm) length of cavity, xpas(cm): step length
25668  ! 8 steps over a cell
25669  npas = ncell*10
25670  xpas = ylg/float(npas)
25671  e0 = xmat
25672  b0 = vref/vl
25673  b1 = b0
25674  b2 = b0
25675  b3 = b0
25676  b4 = b0
25677  b5 = b0
25678  t0 = 0.
25679  gam0 = 1./sqrt(1.-b0*b0)
25680  xnh = 0.
25681  estop = xpas/10.
25682 20 continue
25683  ! cc if(xnh*xpas.ge.ylg) go to 10
25684  xpat = xnh*xpas
25685  if (xpat<(ylg-estop)) then
25686  call fposb
25687  ! --- enegy gain over the step
25688  ! predictor of energy gain
25689  b1 = b0
25690  b2 = b0
25691  b3 = b0
25692  b4 = b0
25693  b5 = b0
25694  dgam = xi1(phi0, t0, t5)*qst/e0
25695  gam5 = gam0 + dgam
25696  ! corrector of energy gain
25697  xpas2 = xpas*xpas
25698  dgdz = qst/e0*tspl0
25699  d2gdz2 = dgam/xpas2 - dgdz/xpas
25700  d2gdz2 = 2.*d2gdz2
25701  gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
25702  gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
25703  gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
25704  gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
25705  b1 = sqrt(gam1*gam1-1.)/gam1
25706  b2 = sqrt(gam2*gam2-1.)/gam2
25707  b3 = sqrt(gam3*gam3-1.)/gam3
25708  b4 = sqrt(gam4*gam4-1.)/gam4
25709  b5 = sqrt(gam5*gam5-1.)/gam5
25710  dgam = xi1(phi0, t0, t5)*qst/e0
25711  gam5 = gam0 + dgam
25712  b5 = sqrt(gam5*gam5-1.)/gam5
25713  b0 = b5
25714  t0 = t5
25715  gam0 = gam5
25716  xnh = xnh + 1.
25717  go to 20
25718  end if
25719  ! compute an average k: zcrest
25720  zcrest = fh*t5/ylg
25721  return
25722  end subroutine phcrest
25723  ! *******************************************************************
25724  ! SUBROUTINE phcrest1(phi0,ylg,ncell)
25725  ! REFERENCE:
25726  ! computation of the phase giving the maximum energy gain)
25727  ! *******************************************************************
25728  subroutine phcrest1(phi0, ylg, ncell)
25729  implicit real *8(a-h, o-z)
25730  common /cavnum1/xnh, xpas, fmult, npt
25731  common /cavnum2/b0, b1, b2, b3, b4, b5
25732  common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
25733  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
25734  common /consta/vl, pi, xmat, rpel, qst
25735  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25736  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25737  common /dyn/tref, vref
25738  dimension stx(400), sty(400), sts(400), stp(400), stq(400)
25739  dimension phc(100), wph(100)
25740  ! ylg(cm) length of cavity, xpas(cm): step length
25741  npas = ncell*10
25742  xpas = ylg/float(npas)
25743  e0 = xmat
25744  rad = pi/180.
25745  dph = rad
25746  dph1 = rad
25747  dplim = rad*0.01
25748  pmax = phi0 + 10.*rad
25749  pmin = phi0 - 10.*rad
25750  ibcl = 1
25751  phi = pmin
25752 30 continue
25753  if (phi>=pmax) go to 50
25754  phc(ibcl) = phi
25755  b0 = vref/vl
25756  b1 = b0
25757  b2 = b0
25758  b3 = b0
25759  b4 = b0
25760  b5 = b0
25761  t0 = 0.
25762  gam0 = 1./sqrt(1.-b0*b0)
25763  wwref = (gam0-1.)*e0
25764  xnh = 0.
25765 20 continue
25766  if (xnh*xpas>=ylg) go to 10
25767  call fposb
25768  ! --- enegy gain over the step
25769  ! predictor of energy gain
25770  b1 = b0
25771  b2 = b0
25772  b3 = b0
25773  b4 = b0
25774  b5 = b0
25775  dgam = xi1(phi, t0, t5)*qst/e0
25776  gam5 = gam0 + dgam
25777  ! corrector
25778  xpas2 = xpas*xpas
25779  dgdz = qst/e0*tspl0
25780  d2gdz2 = dgam/(xpas2) - dgdz/xpas
25781  d2gdz2 = 2.*d2gdz2
25782  gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
25783  gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
25784  gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
25785  gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
25786  b1 = sqrt(gam1*gam1-1.)/gam1
25787  b2 = sqrt(gam2*gam2-1.)/gam2
25788  b3 = sqrt(gam3*gam3-1.)/gam3
25789  b4 = sqrt(gam4*gam4-1.)/gam4
25790  b5 = sqrt(gam5*gam5-1.)/gam5
25791  dgam = xi1(phi, t0, t5)*qst/e0
25792  gam5 = gam0 + dgam
25793  b5 = sqrt(gam5*gam5-1.)/gam5
25794  b0 = b5
25795  t0 = t5
25796  gam0 = gam5
25797  xnh = xnh + 1.
25798  go to 20
25799 10 continue
25800  wwpcr = (gam0-1.)*e0
25801  dwcpr = wwpcr - wwref
25802  wph(ibcl) = dwcpr
25803  phi = phi + dph
25804  ibcl = ibcl + 1
25805  go to 30
25806 50 continue
25807  ibcl = ibcl - 1
25808  ! save spline areas (partial save)
25809  do i = 1, 400
25810  stx(i) = xspl(i)
25811  sty(i) = yspl(i)
25812  sts(i) = s(i)
25813  stp(i) = p(i)
25814  stq(i) = q(i)
25815  end do
25816  ! padding spline areas
25817  do i = 1, ibcl
25818  xspl(i) = phc(i)
25819  yspl(i) = wph(i)
25820  end do
25821  call deriv2(ibcl)
25822  i = 1
25823  phi = xspl(1)
25824  yfb = slope(ibcl, phi)/100.
25825 70 continue
25826  if (phi>=xspl(ibcl)) go to 60
25827  if (dph1<=dplim) go to 60
25828  yf = slope(ibcl, phi)
25829  ! cccc if(abs(yf).lt.yfb) go to 60
25830  if (yf>0.) then
25831  phi = phi + dph1
25832  go to 70
25833  else
25834  phi = phi - dph1
25835  dph1 = dph1/2.
25836  phi = phi + dph1
25837  go to 70
25838  end if
25839 60 continue
25840  phi0 = phi
25841  ! restore spline areas (partial save)
25842  do i = 1, 400
25843  xspl(i) = stx(i)
25844  yspl(i) = sty(i)
25845  s(i) = sts(i)
25846  p(i) = stp(i)
25847  q(i) = stq(i)
25848  end do
25849  return
25850  end subroutine phcrest1
25851  ! *******************************************************************
25852  ! SUBROUTINE dwref(phi0,gam5,t5)
25853  ! compute the energy gain and the time of flight of the reference
25854  ! over the cavity(gap) at the exit of the cavity(gap):
25855  ! gam4 = relativistic gamma, t4 = tof (cavity)
25856  ! *******************************************************************
25857  subroutine dwref(phi0, gam5, t5)
25858  implicit real *8(a-h, o-z)
25859  common /cavnum1/xnh, xpas, fmult, npt
25860  common /cavnum2/b0, b1, b2, b3, b4, b5
25861  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
25862  common /cavnum7/sspl0, sspl1, sspl2, sspl3, sspl4, sspl5
25863  common /consta/vl, pi, xmat, rpel, qst
25864  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
25865  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25866  common /dyn/tref, vref
25867  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
25868  common /step/istep
25869  common /compt/nrres, nrtre, nrbunc, nrdbun
25870  common /kcell/avrg(15)
25871  common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
25872  common /sphi/tcour1(15), tcour2(15)
25873  common /t3dfld/fldctr(15), zend(15), t3d
25874  logical t3d
25875  ! save previous xpas
25876  xpcel = xpas
25877 
25878  xlpos = 0.
25879  isce = 20
25880  xlcum = 0.
25881  b0 = vref/vl
25882  b1 = b0
25883  b2 = b0
25884  b3 = b0
25885  b4 = b0
25886  b5 = b0
25887  t0 = 0.
25888  ! xlcel (cm): length of current cell
25889  ! xlim(inc) cm: limits of current cell
25890  ! isce: step number in cell (forced isce = 20)
25891  ! wdgam: energy gain over the cell
25892  ! **************************************
25893  do inc = 1, ncell
25894  bcour1(inc) = b0
25895  tcour1(inc) = t0
25896  wdgams = 0.
25897  xnh = 0.
25898  xlcel = xlim(inc+1) - xlim(inc)
25899  xlpos = xlpos + xlcel
25900  xpas = xlcel/float(isce)
25901  e0 = xmat
25902  xnhc = 0
25903  gam0 = 1./sqrt(1.-b0*b0)
25904  estop = xpas/10.
25905  istop = 0
25906 20 continue
25907  xpat = xnhc*xpas
25908  if (xpat<(xlcel-estop)) then
25909  call fposbb(xlcum)
25910  ! --- energy gain over the step
25911  b1 = b0
25912  b2 = b0
25913  b3 = b0
25914  b4 = b0
25915  b5 = b0
25916  ! predictor
25917  dgam = xi1(phi0, t0, t5)*qst/e0
25918  gam5 = gam0 + dgam
25919  ! corrector
25920  xpas2 = xpas*xpas
25921  dgdz = qst/e0*tspl0
25922  d2gdz2 = dgam/xpas2 - dgdz/xpas
25923  d2gdz2 = 2.*d2gdz2
25924  gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
25925  gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
25926  gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
25927  gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
25928  b1 = sqrt(gam1*gam1-1.)/gam1
25929  b2 = sqrt(gam2*gam2-1.)/gam2
25930  b3 = sqrt(gam3*gam3-1.)/gam3
25931  b4 = sqrt(gam4*gam4-1.)/gam4
25932  b5 = sqrt(gam5*gam5-1.)/gam5
25933  dgam = xi1(phi0, t0, t5)*qst/e0
25934  gam5 = gam0 + dgam
25935  eww = xmat*(gam5-1.)
25936  wdgam = xmat*dgam
25937  wdgams = wdgams + wdgam
25938  ! ccc write(13,*) ' inc wdgam eww t5 ',inc,wdgam,eww,t5
25939  b5 = sqrt(gam5*gam5-1.)/gam5
25940  b0 = b5
25941  t0 = t5
25942  gam0 = gam5
25943  xnh = xnh + 1.
25944  xnhc = xnhc + 1.
25945  go to 20
25946  end if
25947  tcour2(inc) = t5
25948  xlcum = xlcum + xlcel
25949  ttvol = t5*fh*180./pi
25950  ttphi = ttvol + tref*fh*180/pi
25951  bcour2(inc) = b5
25952  tr3dw(inc) = wdgams
25953  ! ************************************************
25954  write (13, 101) nrres, inc, xlim(inc), xlim(inc+1), xlcel, eww, wdgams, ttvol, ttphi, avrg(inc)
25955 101 format (2(2x,i4), 8(2x,e12.5))
25956  fldctr(inc) = avrg(inc) - xlim(inc)
25957  zend(inc) = xlcel - fldctr(inc)
25958  end do
25959  call itrd3
25960  ! restore xpas
25961  xpas = xpcel
25962  return
25963  end subroutine dwref
25964  ! *******************************************************************
25965  ! SUBROUTINE itrd3
25966  ! *******************************************************************
25967  subroutine itrd3
25968  implicit real *8(a-h, o-z)
25969  common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
25970  common /consta/vl, pi, xmat, rpel, qst
25971  common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
25972  common /cavnum1/xnh, xpas, ffield, npt
25973  common /sphi/tcour1(15), tcour2(15)
25974  common /kcell/avrg(15)
25975  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
25976  dimension ttr3d(15), str3d(15)
25977 
25978  do nrc = 1, ncell
25979  bcour = (bcour1(nrc)+bcour2(nrc))/2.
25980  ttr3d(nrc) = ta0(bcour, nrc)
25981  end do
25982  do nrc = 1, ncell
25983  bcour = (bcour1(nrc)+bcour2(nrc))/2.
25984  str3d(nrc) = sb0(bcour, nrc)
25985  end do
25986  do nrc = 1, ncell
25987  t0tr3d(nrc) = qst*sqrt(ttr3d(nrc)**2+str3d(nrc)**2)*ffield/2.
25988  atr3d = 0.
25989  tt = tr3dw(nrc)/t0tr3d(nrc)
25990  tph = atan(-str3d(nrc)/ttr3d(nrc))
25991  if (tt<1.) atr3d = acos(tt)
25992  ddw = ttr3d(nrc)*cos(tph) - str3d(nrc)*sin(tph)
25993  if (ddw<0.) then
25994  tph = tph + pi
25995  end if
25996  ! if(tph.ge.pcrest) atr3d=-atr3d
25997  drift1 = avrg(nrc) - xlim(nrc)
25998  drift2 = xlim(nrc+1) - avrg(nrc)
25999  xsign1 = tcour2(nrc) - tcour1(nrc)
26000  xsing = xsign1 - (drift1/bcour1(nrc)+drift2/bcour2(nrc))/vl
26001  if (xsing>0.) atr3d = -atr3d
26002  tr3ph(nrc) = atr3d*180./pi
26003  write (13, 100) nrc, t0tr3d(nrc), ttr3d(nrc), str3d(nrc), tr3dw(nrc), atr3d*180./pi, tph*180./pi
26004 100 format (2x, i4, 6(2x,e12.5))
26005  end do
26006  return
26007  end subroutine itrd3
26008  ! *******************************************************************
26009  ! SUBROUTINE fposbbb(xlcum,fposs,jx)
26010  ! electric field at the 6 Bode's positions in the step (see routine
26011  ! dwref)
26012  ! *******************************************************************
26013  subroutine fposbbb(xlcum, fposs, jx)
26014  implicit real *8(a-h, o-z)
26015  common /cavnum1/xnh, xpas, fmult, npt
26016  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26017  common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26018  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26019  common /rfield/ifield
26020  common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
26021  logical ifield
26022 
26023  if (fposs==0.) then
26024  fpos0 = xnh*xpas + xlcum + fposs
26025  fpos1 = (xnh+0.20)*xpas + xlcum + fposs
26026  fpos2 = (xnh+0.40)*xpas + xlcum + fposs
26027  fpos3 = (xnh+0.60)*xpas + xlcum + fposs
26028  fpos4 = (xnh+0.80)*xpas + xlcum + fposs
26029  fpos5 = (xnh+1.0)*xpas + xlcum + fposs
26030  else
26031  fpos0 = xnh*xpas + fposs
26032  fpos1 = (xnh+0.20)*xpas + fposs
26033  fpos2 = (xnh+0.40)*xpas + fposs
26034  fpos3 = (xnh+0.60)*xpas + fposs
26035  fpos4 = (xnh+0.80)*xpas + fposs
26036  fpos5 = (xnh+1.0)*xpas + fposs
26037  end if
26038  if (jx==1) then
26039  xnh1 = xnh + 1
26040  if (xnh1==float(iscx(jx))) fposs = fpos5
26041  end if
26042  if (ifield) then
26043  ! --- the field is read from disk in MV/cm
26044  tspl0 = spline(npt, fpos0)*fmult
26045  tspl1 = spline(npt, fpos1)*fmult
26046  tspl2 = spline(npt, fpos2)*fmult
26047  tspl3 = spline(npt, fpos3)*fmult
26048  tspl4 = spline(npt, fpos4)*fmult
26049  tspl5 = spline(npt, fpos5)*fmult
26050  ! ****TEST
26051  ! cc write(13,*) 'xnh fpos tspl '
26052  ! write(13,700) xnh,fpos0,tspl0,xpas,fposs
26053  ! write(13,700) xnh,fpos1,tspl1
26054  ! write(13,700) xnh,fpos2,tspl2
26055  ! write(13,700) xnh,fpos3,tspl3
26056  ! write(13,700) xnh,fpos4,tspl4
26057  ! write(13,700) xnh,fpos5,tspl5,xpas,fposs
26058  ! 700 format(5(2x,e12.5))
26059  ! ***********************************
26060  go to 10
26061  else
26062  ! ++++ THIS OPTION IS NOT AVAILABLE IN THE CODE +++++++++++++
26063  ! the field (MV/cm) is given in the form of a Fourier series
26064  tspl0 = fone(fpos0)*fmult
26065  tspl1 = fone(fpos1)*fmult
26066  tspl2 = fone(fpos2)*fmult
26067  tspl3 = fone(fpos3)*fmult
26068  tspl4 = fone(fpos4)*fmult
26069  tspl5 = fone(fpos5)*fmult
26070  ! ****TEST
26071  ! old write(6,*) 'xnh fmult ',xnh,fmult
26072  ! c write(70,700) fpos0,tspl0
26073  ! c write(70,700) fpos1,tspl1
26074  ! c write(70,700) fpos2,tspl2
26075  ! c write(70,700) fpos3,tspl3
26076  ! c write(70,700) fpos4,tspl4
26077  ! old write(70,700) fpos5,tspl5
26078  ! ***********************************
26079  end if
26080 10 continue
26081  return
26082  end subroutine fposbbb
26083  ! *******************************************************************
26084  ! SUBROUTINE fposbb(xlcum)
26085  ! electric field at the 6 Bode's positions in the step (see routine
26086  ! dwref1)
26087  ! *******************************************************************
26088  subroutine fposbb(xlcum)
26089  implicit real *8(a-h, o-z)
26090  common /cavnum1/xnh, xpas, fmult, npt
26091  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26092  common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26093  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26094  common /rfield/ifield
26095  logical ifield
26096  ! *******************************************
26097  fpos0 = xnh*xpas + xlcum
26098  fpos1 = (xnh+0.20)*xpas + xlcum
26099  fpos2 = (xnh+0.40)*xpas + xlcum
26100  fpos3 = (xnh+0.60)*xpas + xlcum
26101  fpos4 = (xnh+0.80)*xpas + xlcum
26102  fpos5 = (xnh+1.0)*xpas + xlcum
26103  if (ifield) then
26104  ! --- the field is read from disk in MV/cm
26105  tspl0 = spline(npt, fpos0)*fmult
26106  tspl1 = spline(npt, fpos1)*fmult
26107  tspl2 = spline(npt, fpos2)*fmult
26108  tspl3 = spline(npt, fpos3)*fmult
26109  tspl4 = spline(npt, fpos4)*fmult
26110  tspl5 = spline(npt, fpos5)*fmult
26111  ! ****TEST
26112  ! cc write(13,*) 'xnh fpos tspl '
26113  ! c write(13,700) xnh,fpos0,tspl0,xpas
26114  ! write(13,700) xnh,fpos1,tspl1
26115  ! write(13,700) xnh,fpos2,tspl2
26116  ! write(13,700) xnh,fpos3,tspl3
26117  ! write(13,700) xnh,fpos4,tspl4
26118  ! write(13,700) xnh,fpos5,tspl5,xpas
26119  ! 700 format(4(2x,e12.5))
26120  ! ***********************************
26121  go to 10
26122  else
26123  ! the field (MV/cm) is given in the form of a Fourier series
26124  tspl0 = fone(fpos0)*fmult
26125  tspl1 = fone(fpos1)*fmult
26126  tspl2 = fone(fpos2)*fmult
26127  tspl3 = fone(fpos3)*fmult
26128  tspl4 = fone(fpos4)*fmult
26129  tspl5 = fone(fpos5)*fmult
26130  ! ****TEST
26131  ! old write(6,*) 'xnh fmult ',xnh,fmult
26132  ! c write(70,700) fpos0,tspl0
26133  ! c write(70,700) fpos1,tspl1
26134  ! c write(70,700) fpos2,tspl2
26135  ! c write(70,700) fpos3,tspl3
26136  ! c write(70,700) fpos4,tspl4
26137  ! old write(70,700) fpos5,tspl5
26138  ! ***********************************
26139  end if
26140 10 continue
26141  return
26142  end subroutine fposbb
26143  ! *******************************************************************
26144  ! SUBROUTINE fposb
26145  ! electric field at the 6 Bode's positions in the step
26146  ! *******************************************************************
26147  subroutine fposb
26148  implicit real *8(a-h, o-z)
26149  common /cavnum1/xnh, xpas, fmult, npt
26150  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26151  common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26152  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26153  common /rfield/ifield
26154  logical ifield
26155 
26156  fpos0 = xnh*xpas
26157  fpos1 = (xnh+0.20)*xpas
26158  fpos2 = (xnh+0.40)*xpas
26159  fpos3 = (xnh+0.60)*xpas
26160  fpos4 = (xnh+0.80)*xpas
26161  fpos5 = (xnh+1.0)*xpas
26162  if (ifield) then
26163  ! --- the field is read from disk in MV/cm
26164  tspl0 = spline(npt, fpos0)*fmult
26165  tspl1 = spline(npt, fpos1)*fmult
26166  tspl2 = spline(npt, fpos2)*fmult
26167  tspl3 = spline(npt, fpos3)*fmult
26168  tspl4 = spline(npt, fpos4)*fmult
26169  tspl5 = spline(npt, fpos5)*fmult
26170  ! ****TEST
26171  ! old write(6,*) 'xnh fmult ',xnh,fmult
26172  ! c write(13,700) xnh,fpos0,tspl0
26173  ! c write(13,700) xnh,fpos1,tspl1
26174  ! c write(13,700) xnh,fpos2,tspl2
26175  ! c write(13,700) xnh,fpos3,tspl3
26176  ! c write(13,700) xnh,fpos4,tspl4
26177  ! c write(13,700) xnh,fpos5,tspl5
26178  ! c700 format(3(2x,e12.5))
26179  ! ***********************************
26180  go to 10
26181  else
26182  ! the field (MV/cm) is given in the form of a Fourier series
26183  tspl0 = fone(fpos0)*fmult
26184  tspl1 = fone(fpos1)*fmult
26185  tspl2 = fone(fpos2)*fmult
26186  tspl3 = fone(fpos3)*fmult
26187  tspl4 = fone(fpos4)*fmult
26188  tspl5 = fone(fpos5)*fmult
26189  ! ****TEST
26190  ! old write(6,*) 'xnh fmult ',xnh,fmult
26191  ! c write(70,700) fpos0,tspl0
26192  ! c write(70,700) fpos1,tspl1
26193  ! c write(70,700) fpos2,tspl2
26194  ! c write(70,700) fpos3,tspl3
26195  ! c write(70,700) fpos4,tspl4
26196  ! old write(70,700) fpos5,tspl5
26197  ! ***********************************
26198  end if
26199 10 continue
26200  return
26201  end subroutine fposb
26202  ! *******************************************************************
26203  ! SUBROUTINE sposb
26204  ! derivative of electric field at the 6 Bode's positions in the step
26205  ! not used in the code
26206  ! *******************************************************************
26207  subroutine sposb
26208  implicit real *8(a-h, o-z)
26209  common /cavnum1/xnh, xpas, fmult, npt
26210  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26211  common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
26212  common /cavnum7/sspl0, sspl1, sspl2, sspl3, sspl4, sspl5
26213  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26214  common /rfield/ifield
26215  logical ifield
26216 
26217  fpos0 = xnh*xpas
26218  fpos1 = (xnh+0.20)*xpas
26219  fpos2 = (xnh+0.40)*xpas
26220  fpos3 = (xnh+0.60)*xpas
26221  fpos4 = (xnh+0.80)*xpas
26222  fpos5 = (xnh+1.0)*xpas
26223  if (ifield) then
26224  ! --- the field is read from disk in MV/cm
26225  sspl0 = slope(npt, fpos0)*fmult
26226  sspl1 = slope(npt, fpos1)*fmult
26227  sspl2 = slope(npt, fpos2)*fmult
26228  sspl3 = slope(npt, fpos3)*fmult
26229  sspl4 = slope(npt, fpos4)*fmult
26230  sspl5 = slope(npt, fpos5)*fmult
26231  ! ****TEST
26232  ! old write(6,*) 'xnh fmult ',xnh,fmult
26233  ! cc write(13,700) xnh,fpos0,sspl0
26234  ! cc write(13,700) xnh,fpos1,sspl1
26235  ! cc write(13,700) xnh,fpos2,sspl2
26236  ! cc write(13,700) xnh,fpos3,sspl3
26237  ! cc write(13,700) xnh,fpos4,sspl4
26238  ! cc write(13,700) xnh,fpos5,sspl5
26239  ! cc700 format(3(2x,e12.5))
26240  ! ***********************************
26241  go to 10
26242  else
26243  ! the field (MV/cm) is given in the form of a Fourier series
26244  tspl0 = fone(fpos0)*fmult
26245  tspl1 = fone(fpos1)*fmult
26246  tspl2 = fone(fpos2)*fmult
26247  tspl3 = fone(fpos3)*fmult
26248  tspl4 = fone(fpos4)*fmult
26249  tspl5 = fone(fpos5)*fmult
26250  ! ****TEST
26251  ! old write(6,*) 'xnh fmult ',xnh,fmult
26252  ! c write(70,700) fpos0,tspl0
26253  ! c write(70,700) fpos1,tspl1
26254  ! c write(70,700) fpos2,tspl2
26255  ! c write(70,700) fpos3,tspl3
26256  ! c write(70,700) fpos4,tspl4
26257  ! old write(70,700) fpos5,tspl5
26258  ! ***********************************
26259  end if
26260 10 continue
26261  return
26262  end subroutine sposb
26263  ! *******************************************************************
26264  ! FUNCTION xi1(phi0,t0,t5)
26265  ! energy gain over the step
26266  ! *******************************************************************
26267  function xi1(phi0, t0, t5)
26268  implicit real *8(a-h, o-z)
26269  common /cavnum1/xnh, xpas, fmult, npt
26270  common /cavnum2/b0, b1, b2, b3, b4, b5
26271  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26272  common /consta/vl, pi, xmat, rpel, qst
26273  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26274 
26275  xi1 = 0.
26276  b01 = (b0+b1)/2.
26277  b12 = (b1+b2)/2.
26278  b23 = (b2+b3)/2
26279  b34 = (b3+b4)/2
26280  b45 = (b4+b5)/2
26281  t1 = t0 + xpas/(5.*b01*vl)
26282  t2 = t1 + xpas/(5.*b12*vl)
26283  t3 = t2 + xpas/(5.*b23*vl)
26284  t4 = t3 + xpas/(5.*b34*vl)
26285  t5 = t4 + xpas/(5.*b45*vl)
26286  xspl0 = cos(fh*t0+phi0)*tspl0
26287  xspl1 = cos(fh*t1+phi0)*tspl1
26288  xspl2 = cos(fh*t2+phi0)*tspl2
26289  xspl3 = cos(fh*t3+phi0)*tspl3
26290  xspl4 = cos(fh*t4+phi0)*tspl4
26291  xspl5 = cos(fh*t5+phi0)*tspl5
26292  tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
26293  xi1 = xpas/288.*tspl
26294  return
26295  end function xi1
26296  ! *******************************************************************
26297  ! FUNCTION xi2(phi0,t0)
26298  ! coupling terms in R and R' (energy gain)
26299  ! *******************************************************************
26300  function xi2(phi0, t0)
26301  implicit real *8(a-h, o-z)
26302  common /cavnum1/xnh, xpas, fmult, npt
26303  common /cavnum2/b0, b1, b2, b3, b4, b5
26304  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26305  common /consta/vl, pi, xmat, rpel, qst
26306  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26307 
26308  b01 = (b0+b1)/2.
26309  b12 = (b1+b2)/2.
26310  b23 = (b2+b3)/2.
26311  b34 = (b3+b4)/2.
26312  b45 = (b4+b5)/2.
26313  t1 = t0 + xpas/(5.*b01*vl)
26314  t2 = t1 + xpas/(5.*b12*vl)
26315  t3 = t2 + xpas/(5.*b23*vl)
26316  t4 = t3 + xpas/(5.*b34*vl)
26317  t5 = t4 + xpas/(5.*b45*vl)
26318  ! old xspl0=cos(fh*t0+phi0)*tspl0
26319  xspl1 = cos(fh*t1+phi0)*tspl1
26320  xspl2 = cos(fh*t2+phi0)*tspl2
26321  xspl3 = cos(fh*t3+phi0)*tspl3
26322  xspl4 = cos(fh*t4+phi0)*tspl4
26323  xspl5 = cos(fh*t5+phi0)*tspl5
26324  tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60*xspl4 + 19.*xspl5
26325  xi2 = xpas*xpas/288.*tspl
26326  return
26327  end function xi2
26328  ! *******************************************************************
26329  ! FUNCTION xj1(phi0,t0)
26330  ! transverse motion field dE/dt
26331  ! *******************************************************************
26332  function xj1(phi0, t0)
26333  implicit real *8(a-h, o-z)
26334  common /cavnum1/xnh, xpas, fmult, npt
26335  common /cavnum2/b0, b1, b2, b3, b4, b5
26336  common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
26337  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26338  common /consta/vl, pi, xmat, rpel, qst
26339  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26340  ! --- the field is read on the disk
26341  xj1 = 0.
26342  b01 = (b0+b1)/2.
26343  b12 = (b1+b2)/2.
26344  b23 = (b2+b3)/2.
26345  b34 = (b3+b4)/2.
26346  b45 = (b4+b5)/2.
26347  t1 = t0 + xpas/(5.*b01*vl)
26348  t2 = t1 + xpas/(5.*b12*vl)
26349  t3 = t2 + xpas/(5.*b23*vl)
26350  t4 = t3 + xpas/(5.*b34*vl)
26351  t5 = t4 + xpas/(5.*b45*vl)
26352  xspl0 = -fh*sin(fh*t0+phi0)*tspl0/bgt0
26353  xspl1 = -fh*sin(fh*t1+phi0)*tspl1/bgt1
26354  xspl2 = -fh*sin(fh*t2+phi0)*tspl2/bgt2
26355  xspl3 = -fh*sin(fh*t3+phi0)*tspl3/bgt3
26356  xspl4 = -fh*sin(fh*t4+phi0)*tspl4/bgt4
26357  xspl5 = -fh*sin(fh*t5+phi0)*tspl5/bgt5
26358  tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
26359  xj1 = xpas/288.*tspl
26360  return
26361  end function xj1
26362  ! *******************************************************************
26363  ! FUNCTION xj2(phi0,t0)
26364  ! transverse motion field dE/dt
26365  ! *******************************************************************
26366  function xj2(phi0, t0)
26367  implicit real *8(a-h, o-z)
26368  common /cavnum1/xnh, xpas, fmult, npt
26369  common /cavnum2/b0, b1, b2, b3, b4, b5
26370  common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
26371  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26372  common /consta/vl, pi, xmat, rpel, qst
26373  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26374 
26375  xj2 = 0.
26376  b01 = (b0+b1)/2.
26377  b12 = (b1+b2)/2.
26378  b23 = (b2+b3)/2.
26379  b34 = (b3+b4)/2.
26380  b45 = (b4+b5)/2.
26381  t1 = t0 + xpas/(5.*b01*vl)
26382  t2 = t1 + xpas/(5.*b12*vl)
26383  t3 = t2 + xpas/(5.*b23*vl)
26384  t4 = t3 + xpas/(5.*b34*vl)
26385  t5 = t4 + xpas/(5.*b45*vl)
26386  xspl1 = -fh*sin(fh*t1+phi0)*tspl1/bgt1
26387  xspl2 = -fh*sin(fh*t2+phi0)*tspl2/bgt2
26388  xspl3 = -fh*sin(fh*t3+phi0)*tspl3/bgt3
26389  xspl4 = -fh*sin(fh*t4+phi0)*tspl4/bgt4
26390  xspl5 = -fh*sin(fh*t5+phi0)*tspl5/bgt5
26391  tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60.*xspl4 + 19.*xspl5
26392  xj2 = xpas*xpas/288.*tspl
26393  return
26394  end function xj2
26395  ! *******************************************************************
26396  ! FUNCTION xe21(phi0,t0)
26397  ! transverse motion field E*E
26398  ! *******************************************************************
26399  function xe21(phi0, t0)
26400  implicit real *8(a-h, o-z)
26401  common /cavnum1/xnh, xpas, fmult, npt
26402  common /cavnum2/b0, b1, b2, b3, b4, b5
26403  common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
26404  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26405  common /consta/vl, pi, xmat, rpel, qst
26406  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26407 
26408  xe21 = 0.
26409  b01 = (b0+b1)/2.
26410  b12 = (b1+b2)/2.
26411  b23 = (b2+b3)/2.
26412  b34 = (b3+b4)/2.
26413  b45 = (b4+b5)/2.
26414  t1 = t0 + xpas/(5.*b01*vl)
26415  t2 = t1 + xpas/(5.*b12*vl)
26416  t3 = t2 + xpas/(5.*b23*vl)
26417  t4 = t3 + xpas/(5.*b34*vl)
26418  t5 = t4 + xpas/(5.*b45*vl)
26419  xspl0 = cos(fh*t0+phi0)*tspl0
26420  xspl1 = cos(fh*t1+phi0)*tspl1
26421  xspl2 = cos(fh*t2+phi0)*tspl2
26422  xspl3 = cos(fh*t3+phi0)*tspl3
26423  xspl4 = cos(fh*t4+phi0)*tspl4
26424  xspl5 = cos(fh*t5+phi0)*tspl5
26425  xspl0 = xspl0*xspl0*bge0
26426  xspl1 = xspl1*xspl1*bge1
26427  xspl2 = xspl2*xspl2*bge2
26428  xspl3 = xspl3*xspl3*bge3
26429  xspl4 = xspl4*xspl4*bge4
26430  xspl5 = xspl5*xspl5*bge5
26431  tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
26432  xe21 = xpas/288.*tspl
26433  return
26434  end function xe21
26435  ! *******************************************************************
26436  ! FUNCTION xe22(phi0,t0)
26437  ! transverse motion for field E*E
26438  ! *******************************************************************
26439  function xe22(phi0, t0)
26440  implicit real *8(a-h, o-z)
26441  common /cavnum1/xnh, xpas, fmult, npt
26442  common /cavnum2/b0, b1, b2, b3, b4, b5
26443  common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
26444  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26445  common /consta/vl, pi, xmat, rpel, qst
26446  common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
26447  common /dyn/tref, vref
26448  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26449  common /rfield/ifield
26450  logical ifield
26451 
26452  xe22 = 0.
26453  b01 = (b0+b1)/2.
26454  b12 = (b1+b2)/2.
26455  b23 = (b2+b3)/2.
26456  b34 = (b3+b4)/2.
26457  b45 = (b4+b5)/2.
26458  t1 = t0 + xpas/(5.*b01*vl)
26459  t2 = t1 + xpas/(5.*b12*vl)
26460  t3 = t2 + xpas/(5.*b23*vl)
26461  t4 = t3 + xpas/(5.*b34*vl)
26462  t5 = t4 + xpas/(5.*b45*vl)
26463  xspl1 = cos(fh*t1+phi0)*tspl1
26464  xspl2 = cos(fh*t2+phi0)*tspl2
26465  xspl3 = cos(fh*t3+phi0)*tspl3
26466  xspl4 = cos(fh*t4+phi0)*tspl4
26467  xspl5 = cos(fh*t4+phi0)*tspl5
26468  xspl1 = xspl1*xspl1*bge1
26469  xspl2 = xspl2*xspl2*bge2
26470  xspl3 = xspl3*xspl3*bge3
26471  xspl4 = xspl4*xspl4*bge4
26472  xspl5 = xspl5*xspl5*bge5
26473  tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60.*xspl4 + 19.*xspl5
26474  xe22 = xpas*xpas/288.*tspl
26475  return
26476  end function xe22
26477  ! *******************************************************************
26478  ! SUBROUTINE bcnum(phref,ylg,ncell)
26479  ! dynamics of the bunch
26480  ! *******************************************************************
26481  subroutine bcnum(phref, ylg, ncell)
26482  implicit real *8(a-h, o-z)
26483  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
26484  common /dyn/tref, vref
26485  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
26486  common /dcspa/iesp
26487  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26488  common /faisc/f(10, iptsz), imax, ngood
26489  common /consta/vl, pi, xmat, rpel, qst
26490  common /cavnum1/xnh, xpas, fmult, npt
26491  common /cavnum2/b0, b1, b2, b3, b4, b5
26492  common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
26493  common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
26494  common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
26495  common /rfield/ifield
26496  common /testref/trefs, ddw
26497  common /elec/jelec
26498  common /step/istep
26499  dimension gam(500), xe(500), xpe(500), ye(500), ype(500)
26500  dimension tcour(iptsz), phi(iptsz)
26501  logical ifield, flgsc, ichaes, iesp, jelec
26502  ! ylg(cm) length of cavity, xpas(cm): step length
26503  ! 8 steps over a cell (a voir!!!)
26504  beref = vref/vl
26505  gamref = 1./sqrt(1.-(beref*beref))
26506  enref = xmat*gamref
26507  e0 = xmat
26508  npas = ncell*istep
26509  xpas = ylg/float(npas)
26510  npas1 = npas + 1
26511  xnh = 0.
26512  ! flgsc = true ---> s.c. computation
26513  ! eglsc = 2*xpas : acting length of s.c. computation
26514  eglsc = 2.*xpas
26515  flgsc = .false.
26516  do i = 2, npas1
26517  i1 = i - 1
26518  ! --- seek the field E(z) values in the 6 positions in the step length xh
26519  call fposb
26520  do j = 1, ngood
26521  qc = f(9, j)
26522  gam0 = f(7, j)/e0
26523  gam(i1) = gam0
26524  if (i1==1) then
26525  tcour(j) = 0.
26526  tof = f(6, j)
26527  ! --- rphas: phase delay between the actual particle and the reference (entrance of the cavity)
26528  rphas = fh*(tof-tref)
26529  phi(j) = phref + rphas
26530  end if
26531  t0 = tcour(j)
26532  ddt = t0
26533  ! predictor (energy gain)
26534  b0 = sqrt(gam0*gam0-1.)/gam0
26535  b1 = b0
26536  b2 = b0
26537  b3 = b0
26538  b4 = b0
26539  b5 = b0
26540  dgam = xi1(phi(j), t0, t5)*qc/e0
26541  gam5 = gam(i1) + dgam
26542  ! corrector (energy gain)
26543  ! tspl0 = dE/dz (MV/(cm*cm)
26544  xpas2 = xpas*xpas
26545  dgdz = qst/e0*tspl0
26546  d2gdz2 = dgam/xpas2 - dgdz/xpas
26547  d2gdz2 = 2.*d2gdz2
26548  gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
26549  gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
26550  gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
26551  gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
26552  b1 = sqrt(gam1*gam1-1.)/gam1
26553  b2 = sqrt(gam2*gam2-1.)/gam2
26554  b3 = sqrt(gam3*gam3-1.)/gam3
26555  b4 = sqrt(gam4*gam4-1.)/gam4
26556  b5 = sqrt(gam5*gam5-1.)/gam5
26557  dgam = xi1(phi(j), t0, t5)*qc/e0
26558  gam5 = gam(i1) + dgam
26559  b5 = sqrt(gam5*gam5-1.)/gam5
26560  ! tranverse coordinates in (cm,rad)
26561  x0 = f(2, j)
26562  y0 = f(4, j)
26563  xt0 = f(3, j)*1.e-03
26564  yp0 = f(5, j)*1.e-03
26565  ! Picht transformation: xe0 and ye0 (cm) xpe0 and ype0 (rad)
26566  gamm0 = (gam0*gam0-1.)**0.25
26567  xe0 = x0*gamm0
26568  xpe0 = xt0*gamm0
26569  ye0 = y0*gamm0
26570  ype0 = yp0*gamm0
26571  xpe0 = xpe0 + .5*xe0*gam0*dgdz/(gam0*gam0-1.)
26572  ype0 = ype0 + .5*ye0*gam0*dgdz/(gam0*gam0-1.)
26573  xe(i1) = xe0
26574  xpe(i1) = xpe0
26575  ye(i1) = ye0
26576  ype(i1) = ype0
26577  ! transverse coupling terms
26578  gam00 = gam0*gam0
26579  gam11 = gam1*gam1
26580  gam22 = gam2*gam2
26581  gam33 = gam3*gam3
26582  gam44 = gam4*gam4
26583  bgt0 = (gam00-1.)**1.5
26584  xk1 = fh*fh/(4.*vl*vl*bgt0)
26585  red = sqrt(xe(i1)*xe(i1)+ye(i1)*ye(i1))
26586  red2 = red*red
26587  dred = 0.
26588  if (red>1.e-08) then
26589  dred = xe(i1)*xpe(i1) + ye(i1)*ype(i1)
26590  dred = dred/red
26591  end if
26592  rk1 = xk1*red2*xi1(phi(j), t0, t5)*qc/e0
26593  rk2 = red*dred*xk1*xi2(phi(j), t0)*qc/e0
26594  gam(i) = gam5 + rk1 + rk2
26595  gam55 = gam(i)*gam(i)
26596  bgt1 = (gam11-1.)**1.5
26597  bgt2 = (gam22-1.)**1.5
26598  bgt3 = (gam33-1.)**1.5
26599  bgt4 = (gam44-1.)**1.5
26600  bgt5 = (gam55-1.)**1.5
26601  bge0 = (gam00+2.)/((gam00-1.)*(gam00-1.))
26602  bge1 = (gam11+2.)/((gam11-1.)*(gam11-1.))
26603  bge2 = (gam22+2.)/((gam22-1.)*(gam22-1.))
26604  bge3 = (gam33+2.)/((gam33-1.)*(gam33-1.))
26605  bge4 = (gam44+2.)/((gam44-1.)*(gam44-1.))
26606  bge5 = (gam55+2.)/((gam55-1.)*(gam55-1.))
26607  ! ******************************************************
26608  ! compute the jump of phase over the step
26609  ! old dlt=(1.+red2*xk1)*xi3(phi(j),t0)
26610  ! old dlt=dlt+red*dred*xk1*xi4(phi(j),t0)
26611  ! old dlt=dlt*qc/(e0*vl)
26612  ! old tof=tof+xpas/(vl*b0)+dlt
26613  ! *******************************************************
26614  f(7, j) = gam(i)*e0
26615  tcour(j) = t5
26616  ddt1 = t5 - ddt
26617  f(6, j) = ddt1 + f(6, j)
26618  ! -- angular deviation
26619  ! 1) terms in dE/dt
26620  a1 = qc/(2.*e0*vl)
26621  ttt1 = xj1(phi(j), t0)
26622  ttt2 = xj2(phi(j), t0)
26623  ! old dxpe=xe(i1)*xj1(phi(j),t0)+xpe(i1)*xj2(phi(j),t0)
26624  ! old dype=ye(i1)*xj1(phi(j),t0)+ype(i1)*xj2(phi(j),t0)
26625  dxpe1 = xe(i1)*ttt1 + xpe(i1)*ttt2
26626  dype1 = ye(i1)*ttt1 + ype(i1)*ttt2
26627  xpe(i) = xpe(i1) + a1*dxpe1
26628  ype(i) = ype(i1) + a1*dype1
26629  ! --- 2) terms in E*E (only for no-relativistic electrons)
26630  if (jelec) then
26631  ae2 = qc/(2.*e0)
26632  ae2 = ae2*ae2
26633  stt1 = xe21(phi(j), t0)
26634  stt2 = xe22(phi(j), t0)
26635  dxpe2 = xe(i1)*stt1 + xpe(i1)*stt2
26636  dype2 = ye(i1)*stt1 + ype(i1)*stt2
26637  xpe(i) = xpe(i1) + a1*dxpe1 - ae2*dxpe2
26638  ype(i) = ype(i1) + a1*dype1 - ae2*dype2
26639  end if
26640  ! extension
26641  ! old dxe=xe(i1)*xj2(phi,t0)+xpe(i1)*xj3(phi,t0)
26642  ! old dye=ye(i1)*xj2(phi,t0)+ype(i1)*xj3(phi,t0)
26643  ! old xe(i)=xe(i1)+a1*dxe+xpas*xpe(i1)
26644  ! old ye(i)=ye(i1)+a1*dye+xpas*ype(i1)
26645  xe(i) = xe(i1) + xpas*(xpe(i1)+xpe(i))/2.
26646  ye(i) = ye(i1) + xpas*(ype(i1)+ype(i))/2.
26647  ! back to the real variables and convert to (cm,mrad)
26648  dgdzr = qc/e0*tspl5
26649  gamm1 = (gam(i)*gam(i)-1.)**0.25
26650  gamm2 = (gam(i)*gam(i)-1.)**1.25
26651  xi = xe(i)/gamm1
26652  xpi = xpe(i)/gamm1 - xe(i)*gam(i)*dgdzr/(gamm2*2.)
26653  yi = ye(i)/gamm1
26654  ypi = ype(i)/gamm1 - ye(i)*gam(i)*dgdzr/(gamm2*2.)
26655  ! convert in cm and mrd
26656  f(2, j) = xi
26657  f(4, j) = yi
26658  f(3, j) = xpi*1.e03
26659  f(5, j) = ypi*1.e03
26660  end do
26661  ! space charge computation (only odd step numbers)
26662  if (.not. flgsc) then
26663  flgsc = .true.
26664  call disp
26665  ! et endif
26666  else
26667  ! et if(flgsc) then
26668  if (ichaes) then
26669  ! Charge space (only SCHEFF is available)
26670  iesp = .true.
26671  call cesp(eglsc)
26672  iesp = .false.
26673  flgsc = .false.
26674  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
26675  end if
26676  call disp
26677  end if
26678  xnh = xnh + 1.
26679  end do
26680  return
26681  end subroutine bcnum
26682  ! *******************************************************************
26683  ! SUBROUTINE reject(ilost)
26684  ! reject particles outside window set by REJECT card
26685  ! ---- ifw = 0 ===> wdisp = dW/W relative to cog
26686  ! ---- ifw = 1 ===> wdisp = dW (MeV) relative to cog
26687  ! ---- ifw = 10 ===> wdisp = dW/W relative to REF
26688  ! ---- ifw = 11 ===> wdisp = dW (MeV) relative to REF
26689  ! *******************************************************************
26690  subroutine reject(ilost)
26691  implicit real *8(a-h, o-z)
26692  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
26693  common /consta/vl, pi, xmat, rpel, qst
26694  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26695  common /faisc/f(10, iptsz), imax, ngood
26696  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
26697  common /mcs/imcs, ncstat, cstat(20)
26698  common /etcom/cog(8), exten(17), fd(iptsz)
26699  common /fene/wdisp, wphas, wx, wy, rlim, ifw
26700  common /dyn/tref, vref
26701 
26702  ilost = 0
26703  fh0 = fh/vl
26704  fcpi = fh*180./pi
26705  ! Test window
26706  write (16, *) 'Check if the ', ngood, ' particles are within window'
26707  write (16, *) 'Number of charge states: ', ncstat
26708  if (ifw<=1) then
26709  ! Relative to COG
26710  write (16, 3900)
26711  ! ---- ifw = 0 ===> wdisp = dW/W
26712  ! ---- ifw = 1 ===> wdisp = dW (MeV)
26713  if (ncstat>1) call cogetc
26714  bcour = 0.
26715  cgtv = 0.
26716  do i = 1, ngood
26717  gpai = f(7, i)/xmat
26718  bcour = sqrt(1.-1./(gpai*gpai)) + bcour
26719  cgtv = cgtv + f(6, i)
26720  end do
26721  cgtv = cgtv/float(ngood)
26722  bcour = bcour/float(ngood)
26723  bcg = bcour
26724  gcour = 1./sqrt(1.-bcour*bcour)
26725  gcg = gcour
26726  wcg = (gcour-1.)*xmat
26727  do i = 1, ngood
26728  gpai = f(7, i)/xmat
26729  if (gpai<1.) gpai = 1.
26730  bcour = sqrt(1.-1./(gpai*gpai))
26731  fd(i) = bcour/bcg*gpai/gcg
26732  end do
26733  if (ifw==0) then
26734  dispr = gcour*gcour*wdisp/(gcour*(gcour+1.))
26735  else
26736  dispr = gcour*gcour*wdisp/(gcour*(gcour+1.)*wcg)
26737  end if
26738  else
26739  ! Relative to REF
26740  write (16, 3901)
26741  bref = vref/vl
26742  gref = 1./sqrt(1.-bref*bref)
26743  wref = (gref-1.)*xmat
26744  do i = 1, ngood
26745  gpai = f(7, i)/xmat
26746  bcour = sqrt(1.-1./(gpai*gpai))
26747  fd(i) = bcour/bref*gpai/gref
26748  end do
26749  if (ifw==10) then
26750  dispr = gref*gref*wdisp/(gref*(gref+1.))
26751  else
26752  dispr = gref*gref*wdisp/(gref*(gref+1.)*wref)
26753  end if
26754  end if
26755  write (16, 3927) rlim, wx, wy, wphas, wdisp
26756  ! * ,dispr,f6i*fh*180./pi,f(7,i)-xmat,int(f(9,i))
26757  f6i = 0.
26758  do i = 1, ngood
26759  ray = f(2, i)*f(2, i) + f(4, i)*f(4, i)
26760  ray = sqrt(ray)
26761  if (ray>rlim) f(8, i) = 0.
26762  if (abs(f(2,i))>wx) f(8, i) = 0.
26763  if (abs(f(4,i))>wy) f(8, i) = 0.
26764  if (ifw<=1) then
26765  ! Relative to cog
26766  if (ncstat>1) then
26767  ! ---- each charge state has its own COG in phase
26768  do istc = 1, ncstat
26769  if (f(9,i)==charm(istc)) then
26770  f6i = f(6, i) - cgtdv(istc)
26771  ! tmp=cgtdv(istc)
26772  end if
26773  end do
26774  else
26775  f6i = f(6, i) - cgtv
26776  end if
26777  else
26778  ! Relative to REF
26779  f6i = f(6, i) - tref
26780  end if
26781  if (fh*abs(f6i)>=wphas) then
26782  f(8, i) = 0.
26783  ! write(16,*) "Test1:",fh*abs(f6i),wphas,tmp,f(6,i)
26784  end if
26785  if (abs(fd(i)-1.)>=dispr) then
26786  f(8, i) = 0.
26787  ! write(16,*) "Test2:",abs(fd(i)-1.)
26788  end if
26789  if (f(8,i)==0.) then
26790  write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, f(9, i)
26791  ilost = ilost + 1
26792  end if
26793  end do
26794  ! Reshuffles f(i,j) array after window
26795  call shuffle
26796  ! cccc cstat=1
26797  ncstat = 1
26798  cstat(1) = f(9, 1)
26799  do j = 2, ngood
26800  mcstat = 0
26801  do k = 1, ncstat
26802  if (f(9,j)==cstat(k)) then
26803  mcstat = 1
26804  end if
26805  end do
26806  if (mcstat==0) then
26807  ncstat = ncstat + 1
26808  cstat(ncstat) = f(9, j)
26809  end if
26810  end do
26811  netac = ncstat
26812  write (16, *) 'Number of good particles left: ', ngood
26813  write (16, *) 'Number of charge states left : ', ncstat
26814  write (16, 4030)(cstat(j), j=1, ncstat)
26815  imcs = 0
26816  if (ncstat>1) imcs = 1
26817 3900 format (' Window w.r.t. COG')
26818 3901 format (' Window w.r.t. reference particle')
26819 3927 format (' LIM R,X,Y ', 3(f10.2,9x), 'P,W ', e12.5, 9x, e12.5)
26820 3928 format (' # ', i5, 1x, i5, 1x, 6(f10.2,1x), 1x, f5.2)
26821 4030 format ('Charge state(s): ', 20(f5.1,1x))
26822  return
26823  end subroutine reject
26824  ! *******************************************************************
26825  ! SUBROUTINE aimalv (ANGL,RMO,BAIM,XN,XB,EK1,EK2,PENT1,RAB1,
26826  ! SK1,SK2,PENT2,RAB2)
26827  ! FIRST AND SECOND order Bending Magnet
26828  ! WEDGE BENDING MAGNET
26829  ! ANGL : DEG bend angle of the central trajectory
26830  ! RMO : CM radius of curvature of the central trajectory
26831  ! BAIM : KG field of the bending magnet
26832  ! BAIM = 0 the field is computed from the momentum of the
26833  ! reference; otherwise the momentum is computed from
26834  ! the field
26835  ! XN : FIELD GRADIENT (dimensionless,TRANSPORT: n)
26836  ! XB : NORMALIZED SECOND DERIVATIVE OF B (TRANSPORT : beta)
26837  ! AP(1) = AP(2) CM vertical half aperture (only if IPOLE = 0)
26838  ! ENTRANCE FACE
26839  ! PENT1 EK1 EK2 RAB1
26840  ! PENT1: DEG angle of pole face rotation (deg)
26841  ! RAB1 : CM radius of curvature
26842  ! EK1 : integral related to the extent of the fringing field
26843  ! (TRANSPORT K1)
26844  ! EK2 : integral related to the extent of the fringing field
26845  ! (TRANSPORT K2)
26846  ! AP(1) : CM vertical half aperture
26847  ! EXIT FACE
26848  ! PENT2 SK1 SK2 RAB2
26849  ! PENT2: DEG angle of pole face rotation
26850  ! RAB2 : CM radius of curvature
26851  ! SK1 : integral related to the extent of the fringing field
26852  ! SK2 : integral related to the extent of the fringing field
26853  ! AP(2) : CM vertical half aperture
26854  ! *******************************************************************
26855  subroutine aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
26856  implicit real *8(a-h, o-z)
26857  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
26858  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
26859  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
26860  common /fene/wdisp, wphas, wx, wy, rlim, ifw
26861  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
26862  common /tapes/in, ifile, meta
26863  common /dyn/tref, vref
26864  common /rigid/boro
26865  common /faisc/f(10, iptsz), imax, ngood
26866  common /femt/iemgrw, iemqesg
26867  logical iemgrw
26868  common /etcom/cog(8), exten(17), fd(iptsz)
26869  common /qmoyen/qmoy
26870  common /consta/vl, pi, xmat, rpel, qst
26871  common /bloc23/h, devi, nb, bdb, l
26872  real *8 l, nb
26873  common /poro/irot1, irot2
26874  logical irot1, irot2
26875  common /bloc11/r(6, 6), t(6, 6, 6)
26876  common /bloc21/be, apb(2), layl, layx, rabt
26877  real *8 layl, layx
26878  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
26879  common /rander/ialin
26880  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
26881  common /compt/nrres, nrtre, nrbunc, nrdbun
26882  common /radia/trt, rsync, xintf, crae
26883  common /rayshy/iraysh
26884  logical iraysh
26885  common /itvole/itvol, imamin
26886  common /tofev/ttvols
26887  common /mcs/imcs, ncstat, cstat(20)
26888  ! nsprint: control
26889  common /isector/nsector, nsprint
26890  ! --------------------------------------
26891  logical itvol, imamin, ichaes
26892  character *1 cr
26893  logical ialin
26894  dimension xmoy(20), ymoy(20), rmoy(20), rig(20), ncs(20)
26895  dimension xpmoy(20), ypmoy(20)
26896  dimension xcl1(20), xcl2(20), alp(20), sxeb1(20), charge(20)
26897  dimension xsa1b1(20), baims(20)
26898  ! *et*2013*Apr*1
26899  dimension sbeta(20)
26900 
26901  write (16, 100)
26902 100 format (' ****** BENDING MAGNET: input list ****** ')
26903  if (baim==0.0) then
26904  ! BORO: momentum of reference (kG.cm)
26905  ri = boro
26906  ! --- BAIM: bend field (KG)
26907  baim = abs(ri/rmo)
26908  write (16, '(A,F4.1,A,F12.5,A)') ' Based on reference charge ', qst, ' momentum ', boro, ' (kG.cm)'
26909  else
26910  ! --- RI momentum kG.cm
26911  ri = baim*rmo
26912  end if
26913  devi = angl
26914  nb = xn
26915  bdb = xb
26916  rsync = rmo
26917  gap = wy
26918  ! print out on terminal of transport element # on one and the same line
26919  nrtre = nrtre + 1
26920  cr = char(13)
26921  write (6, 8254) nrtre, nrres, cr
26922 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
26923  ! old IF(IROT1) WRITE(16,1010) PENT1,RAB1,EK1,EK2,APB(1)
26924  if (ichaes) then
26925  write (16, *) '***** beam current: ', beamc, ' mA'
26926  end if
26927  write (16, 1010) pent1, rab1, ek1, ek2, apb(1)
26928 1010 format (' ENTRANCE FACE ******', /, ' ANGLE OF POLE FACE ROTATION ', e12.5, ' DEG', /, &
26929  ' RADIUS OF CURVATURE ', e12.5, ' CM', /, ' FRINGE FIELD CORECTIONS K1 K2', 2(2x,e12.5), /, &
26930  ' VERTICAL HALF-APERTURE ', e12.5, ' CM')
26931  write (16, 1020) rmo, devi, baim, nb, bdb
26932 1020 format (' WEDGE MAGNET************', /, ' BENDING RADIUS: ', e12.5, ' CM ', /, ' BEND ANGLE: ', e12.5, &
26933  ' DEG', /, ' FIELD: ', e12.5, ' KG', /, ' FIELD GRADIENTS: N ', e12.5, ' BETA:', e12.5)
26934  ! old IF(IROT2) WRITE(16,1030) PENT2,RAB2,SK1,SK2,APB(2)
26935  write (16, 1030) pent2, rab2, sk1, sk2, apb(2)
26936 1030 format (' EXIT FACE******', /, ' ANGLE OF POLE FACE ROTATION ', e12.5, ' DEG', /, &
26937  ' RADIUS OF CURVATURE ', e12.5, 'CM', /, ' FRINGE FIELD CORRECTIONS K1 K2', 2(2x,e12.5), /, &
26938  ' VERTICAL HALF-APERTURE ', e12.5, ' CM')
26939  ! start prints in file 'short.data'
26940  idav = idav + 1
26941  iitem(idav) = 4
26942  dav1(idav, 2) = devi
26943  dav1(idav, 3) = rmo*10.
26944  dav1(idav, 5) = apb(1)*10.
26945  dav1(idav, 6) = pent1
26946  dav1(idav, 7) = ek1
26947  dav1(idav, 8) = ek2
26948  dav1(idav, 9) = rab1*10.
26949  dav1(idav, 10) = pent2
26950  dav1(idav, 11) = sk1
26951  dav1(idav, 12) = sk2
26952  dav1(idav, 13) = rab2*10.
26953  dav1(idav, 14) = nb
26954  dav1(idav, 15) = bdb
26955  dav1(idav, 16) = baim*.1
26956  dav1(idav, 17) = apb(2)*10.
26957  fh0 = fh/vl
26958  ! Conversion deg--->rad
26959  radia = pi/180.
26960  pent1 = pent1*radia
26961  devi = devi*radia
26962  devr = devi
26963  l = devr*rmo
26964  dav1(idav, 1) = l*10.
26965  sdavtot = davtot
26966  davtot = davtot + l
26967  dav1(idav, 4) = davtot*10.
26968  pent2 = pent2*radia
26969  devtot = devi
26970  ! ----------------------------
26971  ! define the bending angle of the synchronous particle over each sector
26972  devit = devi/float(nsector)
26973  ! --- devit must be different from pent2
26974  if (devit==pent2) nsector = nsector + 1
26975  ! --- space charge computation: nsector must be g.t. 1
26976  if (ichaes .and. (nsector==1)) nsector = 2
26977  devi = devi/float(nsector)
26978  devr = devr/float(nsector)
26979  ! ----------------------------------------------------------
26980  ! -- scl effective length for space charge computation
26981  ! scl is the path length of the C.T. over two following sectors
26982  scl = 2.*devi*rmo
26983  ! save pent1 , pent2 , devi, ek1, ek2 ,sk1 , sk2 ,
26984  pent1s = pent1
26985  pent2s = pent2
26986  devis = devi
26987  devrs = devr
26988  ek1s = ek1
26989  ek2s = ek2
26990  sk1s = sk1
26991  sk2s = sk2
26992  ! --------------------
26993  do ist = 1, ncstat
26994  xcl2(ist) = 0.
26995  rmoy(ist) = 0.
26996  rig(ist) = 0.
26997  baims(ist) = baim
26998  end do
26999  ! -------------------
27000  ! ---- nsector: number of sectors in the bending magnet
27001  do nsec = 1, nsector
27002  ! write(6,*) '********'
27003  ! write(6,*) ' BENDING MAGNET sector ',nsec
27004  devi = devis
27005  devr = devrs
27006  xlsy = devi*rmo
27007  sdavtot = sdavtot + xlsy
27008  if (nsector>1) then
27009  if (nsec==1) then
27010  pent1 = pent1s
27011  pent2 = 0.
27012  ek1 = ek1s
27013  ek2 = ek2s
27014  sk1 = 0.
27015  sk2 = 0.
27016  end if
27017  if (nsec==nsector) then
27018  pent1 = 0.
27019  pent2 = pent2s
27020  ek1 = 0.
27021  ek2 = 0.
27022  sk1 = sk1s
27023  sk2 = sk2s
27024  end if
27025  if ((nsec>1) .and. (nsec<nsector)) then
27026  pent1 = 0.
27027  pent2 = 0.
27028  ek1 = 0.0001
27029  ek2 = 0.
27030  sk1 = 0.0001
27031  sk2 = 0.
27032  end if
27033  end if
27034  ! ------------------------------------------------------------
27035  ! --- nsctat: number of charges in the beam
27036  do ist = 1, ncstat
27037  charge(ist) = cstat(ist)
27038  devi = devis
27039  devr = devrs
27040  xcl1(ist) = pent1 - xcl2(ist)
27041  xmoy(ist) = 0.
27042  xpmoy(ist) = 0.
27043  ymoy(ist) = 0.
27044  ypmoy(ist) = 0.
27045  ncs(ist) = 0
27046  rig(ist) = 0.
27047  sbeta(ist) = 0.
27048  do i = 1, ngood
27049  if (f(9,i)==charge(ist)) then
27050  xmoy(ist) = xmoy(ist) + f(2, i)
27051  ymoy(ist) = ymoy(ist) + f(4, i)
27052  xpmoy(ist) = xpmoy(ist) + f(3, i)
27053  ypmoy(ist) = ypmoy(ist) + f(5, i)
27054  gpai = f(7, i)/xmat
27055  bpai = sqrt(1.-1./(gpai*gpai))
27056  sbeta(ist) = sbeta(ist) + bpai
27057  xmco = xmat*bpai*gpai
27058  rip = 33.356*xmco*1.e-01/f(9, i)
27059  rig(ist) = rip + rig(ist)
27060  ! old rmoy(ist)=rmoy(ist)+rip
27061  ncs(ist) = ncs(ist) + 1
27062  end if
27063  end do
27064  sbeta(ist) = sbeta(ist)/float(ncs(ist))
27065  xmoy(ist) = xmoy(ist)/float(ncs(ist))
27066  ymoy(ist) = ymoy(ist)/float(ncs(ist))
27067  xpmoy(ist) = xpmoy(ist)/float(ncs(ist))
27068  ypmoy(ist) = ypmoy(ist)/float(ncs(ist))
27069  rig(ist) = rig(ist)/float(ncs(ist))
27070  ! old rmoy(ist)=rig(ist)/baim
27071  rmoy(ist) = rig(ist)/baims(ist)
27072  ! eq.14
27073  ctan = cos(devi-pent2)/sin(devi-pent2)
27074  xep = rmo*(sin(devi)*ctan-cos(devi))
27075  xepc = xep + rmo - rmoy(ist) + xmoy(ist)
27076  ! eq.15 and eq.16
27077  argu = -xmoy(ist)*tan(pent1)/xepc
27078  ! eq.16
27079  omga = atan(argu)
27080  ! eq.15
27081  thet = omga + devi - pent2
27082  ! eq.18
27083  eo1 = xepc/cos(omga)
27084  ! eq.17
27085  arg1 = eo1*sin(thet)/rmoy(ist)
27086  eta = asin(arg1)
27087  ! eq.13
27088  xeb1 = xepc*cos(thet)/cos(omga) + rmoy(ist)*cos(eta)
27089  sxeb1(ist) = xeb1
27090  ! eq.12
27091  xk2b1 = -xmoy(ist)*tan(xcl1(ist)) + xeb1*sin(devi-pent2)
27092  ! eq.11 (bend angle)
27093  alp(ist) = asin(xk2b1/rmoy(ist))
27094  ! eq.18
27095  xeo1 = xepc/cos(omga)
27096  ! eq.19 (angle of inclination exit)
27097  argu = eo1/rmoy(ist)*sin(thet)
27098  xcl2(ist) = asin(argu)
27099  sa1b1 = -rmo*sin(devr)
27100  sa1b1 = sa1b1/sin(devr-pent2)
27101  xsa1b1(ist) = sa1b1 + sxeb1(ist)
27102  ! --- field
27103  ! first order
27104  baims(ist) = baim*(1.-nb*xsa1b1(ist)/rmo)
27105  ! second order
27106  rih = 1./(rmo*rmo)
27107  baims(ist) = baims(ist) + xb*rih*xsa1b1(ist)*xsa1b1(ist)
27108  ! -----------------------------------------------------
27109  ! ---- Transport matrix
27110  sbet = sbeta(ist)
27111  devi = alp(ist)
27112  ailong = devi*rmoy(ist)
27113  write (16, 101) charge(ist), nsec, nsector, baims(ist), xsa1b1(ist), rmoy(ist), devi*180./pi, ailong, rig(ist)
27114 101 format (/, ' **************************************', /, ' *CENTRAL TRAJECTORY for charge: ', f4.1, ' *', /, &
27115  ' **************************************', /, ' SECTOR: ', i4, ' SECTORS NUMBER: ', i5, /, &
27116  ' BENDING FIELD: ', e12.5, ' kG at: ', e12.5, ' cm', /, ' BENDING RADIUS: ', e12.5, ' CM ', /, &
27117  ' BENDING ANGLE: ', e12.5, ' DEG', /, ' length: ', e12.5, ' cm rigidity: ', e12.5, ' kG.cm')
27118  l = ailong
27119  h = 1./rmoy(ist)
27120  ! ENTRANCE FACE OF THE BENDING MAGNET
27121  ! CLEAR R AND T
27122  call clear
27123  gap = apb(1)
27124  be = xcl1(ist)
27125  layl = ek1
27126  layx = ek2
27127  rabt = 0.
27128  if (abs(rab1)>6.*0) rabt = 1./rab1
27129  ! -----------------------------------------
27130  gcog = 0.
27131  nii = 0
27132  do ii = 1, ngood
27133  if (f(9,ii)==charge(ist)) then
27134  gcog = gcog + f(7, ii)/xmat
27135  nii = nii + 1
27136  end if
27137  end do
27138  gcog = gcog/float(nii)
27139  bcog = sqrt(1.-1./(gcog*gcog))
27140  fdtot = 0.
27141  do ii = 1, ngood
27142  if (f(9,ii)==charge(ist)) then
27143  tbe = tan(be)
27144  f(2, ii) = f(2, ii) - xmoy(ist)
27145  gpai = f(7, ii)/xmat
27146  bpai = sqrt(1.-1./(gpai*gpai))
27147  f(6, ii) = f(6, ii) + xmoy(ist)*tbe/(bpai*vl)
27148  fd(ii) = (gpai*bpai)/(gcog*bcog)
27149  fdtot = fdtot + fd(ii)
27150  end if
27151  end do
27152  ! TEST
27153  fdtot = fdtot/float(nii) - 1.
27154  ! --------------------------------------------------
27155  call pofar1(gap)
27156  write (16, 4502) be*180./pi, charge(ist)
27157 4502 format (' ****INPUT FACE*** SLOPE: ', e12.5, ' deg ', 'CHARGE: ', f4.1)
27158  call matrix
27159  xll = 0.
27160  do ii = 1, ngood
27161  if (f(9,ii)==charge(ist)) then
27162  call cobeam(ii, xll)
27163  end if
27164  end do
27165  ! *******************************************************
27166  ! WEDGE BENDING MAGNET
27167  ! CLEAR R AND T
27168  call clear
27169  call benmag(sbet, fdtot)
27170  ! --- :print the transport matrix
27171  write (16, 4101) charge(ist)
27172 4101 format (' ****BENDING MAGNET for charge ', f4.1)
27173  call matrix
27174  r51 = r(5, 1)
27175  ! ---- transport of particles
27176  do ii = 1, ngood
27177  if (f(9,ii)==charge(ist)) then
27178  call cobeam(ii, l)
27179  end if
27180  ! synchrotron radiation (only for electrons, i.e. erest = 0.511 Mev)
27181  if (iraysh .and. xmat==0.511) call syrout(ii)
27182  end do
27183  ! *******************************************************
27184  ! --- EXIT FACE OF THE BENDING MAGNET
27185  ! CLEAR R AND T
27186  call clear
27187  xll = 0.
27188  gap = apb(2)
27189  be = xcl2(ist)
27190  layl = sk1
27191  layx = sk2
27192  rabt = 0.
27193  if (abs(rab2)>1.e-10) rabt = 1./rab2
27194  call pofar2(gap)
27195  ! ---- :print the transport matrix
27196  write (16, 4501) be*180./pi, charge(ist)
27197 4501 format (' ****EXIT FACE*** SLOPE: ', e12.5, ' deg CHARGE: ', f4.1)
27198  call matrix
27199  ! transport of particles
27200  xll = 0.
27201  do ii = 1, ngood
27202  if (f(9,ii)==charge(ist)) then
27203  call cobeam(ii, xll)
27204  end if
27205  end do
27206  ! -------------------------------------------------------------------------
27207  ! --- get back the particles coordinates in the coordinates system of the synchronous particle
27208  sa1b1 = -rmo*sin(devr)
27209  sa1b1 = sa1b1/sin(devr-pent2)
27210  ttt = xcl2(ist) - pent2
27211  ttt = ttt*1.e03
27212  do ii = 1, ngood
27213  if (f(9,ii)==charge(ist)) then
27214  ! EQ.29
27215  a1b1 = sa1b1 + sxeb1(ist)
27216  ! EQ.28
27217  f(2, ii) = (a1b1+f(2,ii)/cos(xcl2(ist)))*cos(pent2)
27218  ! EQ.30
27219  f(3, ii) = f(3, ii) - ttt
27220  ! EQ.31
27221  gpai = f(7, ii)/xmat
27222  bpai = sqrt(1.-1./(gpai*gpai))
27223  f(6, ii) = f(6, ii) + r51*xmoy(ist)/(bpai*vl)
27224  ! cc f(6,ii)=f(6,ii)-r51*xmoy(ist)/(bpai*vl)
27225  ! **** allow plotting the beam after the sector number nsprint in file 13 (see the MAIN)
27226  ! cc if(nsec.eq.nsprint) then
27227  ! cc write(13,2587) nsec,ist,charge(ist),f(2,ii),f(3,ii),f(4,ii),
27228  ! cc * f(5,ii),xmoy(ist),ymoy(ist),rmoy(ist)
27229  ! cc2587 format(2x,i3,2x,i3,8(2x,e12.5))
27230  ! cc endif
27231  ! ***************************************************************************
27232  end if
27233  end do
27234  ! enddo for ist (number of charges in the beam)
27235  end do
27236  ! --------------------------------------------------------------
27237  ! Space charge computation
27238  if (ichaes) then
27239  ! --- check the parity of nsec
27240  pnsec = float(nsec)/2. - nsec/2
27241  ! nsec is odd:---> space charge computation
27242  if ((pnsec/=0.) .and. (nsec<nsector)) then
27243  call cesp(scl)
27244  write (16, *) ' space charge after sector: ', nsec
27245  end if
27246  end if
27247  ! ------------------------------------------------------------
27248  ! synchronous radiation (only for electrons i.e. erest = 0.511 Mev)
27249  if (iraysh .and. xmat==0.511) call syref
27250  ! The routine SYREF changes vref and tref (reference)
27251  ! envelope
27252  call stapl(sdavtot*10.)
27253  ! enddo for nsec (sectors numbers)
27254  end do
27255  ! ------------------------------------------------------
27256  ! random error in alignment
27257  if (ialin) call randali
27258  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
27259  call disp
27260  call cogetc
27261  ! --- Test window after the bending magnet
27262  tcog = 0.
27263  gcog = 0.
27264  do i = 1, ngood
27265  gcog = gcog + f(7, i)/xmat
27266  tcog = tcog + f(6, i)
27267  end do
27268  tcog = tcog/float(ngood)
27269  gcog = gcog/float(ngood)
27270  bcog = sqrt(1.-1./(gcog*gcog))
27271  wcg = (gcog-1.)*xmat
27272  ! devtot: total angle of the bending magnet(computation of tref)
27273  devi = devtot
27274  ailong = devi*rmo
27275  if (iraysh .and. xmat==0.511) go to 2561
27276  tref = tref + ailong/vref
27277  ! ----- window control
27278  call reject(ilost)
27279  ! ---------------------------------------------------
27280  dav1(idav, 37) = ngood
27281  if (itvol) ttvols = tref
27282 2561 continue
27283  beref = vref/vl
27284  gamref = 1./sqrt(1.-beref*beref)
27285  xmco = xmat*beref*gamref
27286  boro = 33.356*xmco*1.e-01/qst
27287  tlong = tref*vref
27288  write (16, 256) beref, gamref, tref, tlong, boro, ngood
27289 256 format (//, 3x, ' *** REFERENCE AT THE EXIT :', /, ' BETA :', e12.5, ' GAMMA :', e12.5, /, ' T.O.F (SEC): ', &
27290  e12.5, ' T.O.F (CM): ', e12.5, /, ' RIGIDITY(KGAUSS.CM) :', e12.5, /, ' NUMBER OF PARTICLES :', i6, /)
27291  if (itvol) write (16, *) ' tof for adjustments: ', ttvols, ' sec'
27292  if (iemgrw) call emiprt(0)
27293  ! old CALL STAPL(davtot*10.)
27294  return
27295  end subroutine aimalv
27296  ! *******************************************************************
27297  ! SUBROUTINE deflect(fdtot)
27298  ! Electrostatic deflector: Transport matrix
27299  ! first order transport matrix (M,RD)
27300  ! drad: horizontal deflector radius (cm)
27301  ! l: length of the central trajectory (cm)
27302  ! kx2, ky2: matrix terms arguments (cm-2)
27303  ! avb: average relativistic beta
27304  ! in this routine drad, l kx2, ky2 are converted to m
27305  ! With matrix elements from F.Hinterberger to Triumf note TRI-DN-05-7
27306  ! *******************************************************************
27307  subroutine deflect(fdtot)
27308  implicit real *8(a-z)
27309  common /bloc11/r(6, 6), t(6, 6, 6)
27310  common /edef/avb, drad, kx2, ky2, l
27311  ! --- convert drad, kx2 , ky2 in m
27312  h = 100./drad
27313  h2 = h*h
27314  al = l*1.e-02
27315  kx2 = kx2*1.e04
27316  ky2 = ky2*1.e04
27317  kx = sqrt(abs(kx2))
27318  ky = sqrt(abs(ky2))
27319  argx = kx*al
27320  argy = ky*al
27321  avb2 = avb*avb
27322  avg = sqrt(1.-avb2)
27323  avg = 1./avg
27324  avg2 = avg*avg
27325  dx = (2.-avb2)*h/kx
27326  dxp = (2.-avb2)*h/kx2
27327  ! ***** variante:(???)
27328  ! dx=h/kx
27329  ! dxp=h/kx2
27330  ! ************************
27331  ! kx2 < 0
27332  if (kx2<6.*0) then
27333  cx = cosh(argx)
27334  sx = sinh(argx)/kx
27335  sxp = sinh(argx)*kx
27336  ! ---------------------------------
27337  ! First order Matrix R (plane (X,XP)
27338  r(1, 1) = cx
27339  r(1, 2) = sx
27340  r(1, 6) = dxp*(1.-cx)
27341  r(2, 1) = sxp
27342  r(2, 2) = cx
27343  r(2, 6) = dx*sx*kx
27344  r(5, 1) = -dx*sx*kx
27345  r(5, 2) = -dxp*(1.-cx)
27346  r(5, 5) = 1.
27347  r(5, 6) = fdtot*al/avg2 - (2.-avb2)*dxp*h*(al-sx)
27348  r(6, 6) = 1.
27349  end if
27350  ! kx2 > 0
27351  if (kx2>6.*0) then
27352  cx = cos(argx)
27353  sx = sin(argx)/kx
27354  sxp = sin(argx)*kx
27355  ! First order Matrix R (plane (X,XP)
27356  r(1, 1) = cx
27357  r(1, 2) = sx
27358  r(1, 6) = dxp*(1.-cx)
27359  r(2, 1) = -sxp
27360  r(2, 2) = cx
27361  r(2, 6) = dx*sx*kx
27362  r(5, 1) = dx*sx*kx
27363  r(5, 2) = dxp*(1.-cx)
27364  r(5, 5) = 1.
27365  r(5, 6) = fdtot*al/avg2 - (2.-avb2)*dxp*h*(al-sx)
27366  r(6, 6) = 1.
27367  end if
27368  ! kx2 = 0
27369  if (kx2==6.*0) then
27370  r(1, 1) = 1.
27371  r(1, 2) = al
27372  r(1, 6) = 0.
27373  r(2, 1) = 0.
27374  r(2, 2) = 1.
27375  r(2, 6) = l*h*(2.-avb2)
27376  r(5, 1) = -l*h*(2.-avb2)
27377  r(5, 2) = 0.
27378  r(5, 5) = 1.
27379  r(5, 6) = al/avg2
27380  end if
27381  ! ky2 < 0
27382  if (ky2<6.*0) then
27383  cy = cosh(argy)
27384  sy = sinh(argy)/ky
27385  syp = sinh(argy)*ky
27386  r(3, 3) = cy
27387  r(3, 4) = sy
27388  r(4, 3) = syp
27389  r(4, 4) = cy
27390  end if
27391  ! ky2 > 0
27392  if (ky2>6.*0) then
27393  cy = cos(argy)
27394  sy = sin(argy)/ky
27395  syp = sin(argy)*ky
27396  r(3, 3) = cy
27397  r(3, 4) = sy
27398  r(4, 3) = -syp
27399  r(4, 4) = cy
27400  end if
27401  ! ky2 = 0
27402  if (ky2==6.*0) then
27403  cy = 1.
27404  sy = al
27405  syp = 0.
27406  r(3, 3) = cy
27407  r(3, 4) = sy
27408  r(4, 3) = syp
27409  r(4, 4) = cy
27410  end if
27411  return
27412  end subroutine deflect
27413  ! *******************************************************************
27414  ! SUBROUTINE e_deflec
27415  ! characteristics of the deflector (central trajectory)
27416  ! input parameters
27417  ! nsector: nombre of sectors in the deflector
27418  ! rm0: radial radius (cm)
27419  ! devtot: bend angle (deg)
27420  ! radii: vertical (radial) radii of curvature (cm)
27421  ! elecf: nominal electric field
27422  ! characteristics of the synchronous particle
27423  ! wt0 :total energy (MeV)
27424  ! qst: electric charge
27425  ! *******************************************************************
27426  subroutine e_deflec
27427  implicit real *8(a-h, o-z)
27428  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27429  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
27430  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
27431  common /fene/wdisp, wphas, wx, wy, rlim, ifw
27432  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
27433  common /tapes/in, ifile, meta
27434  common /dyn/tref, vref
27435  common /erigid/edr0
27436  common /faisc/f(10, iptsz), imax, ngood
27437  common /femt/iemgrw, iemqesg
27438  logical iemgrw
27439  common /etcom/cog(8), exten(17), fd(iptsz)
27440  common /qmoyen/qmoy
27441  common /consta/vl, pi, xmat, rpel, qst
27442  common /edef/avb, drad, kx2, ky2, l
27443  real *8 l, kx2, ky2
27444  common /bloc11/r(6, 6), t(6, 6, 6)
27445  common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
27446  common /rander/ialin
27447  common /cgtof/charm(20), cgtdv(20), nbch(20), netac
27448  common /compt/nrres, nrtre, nrbunc, nrdbun
27449  common /itvole/itvol, imamin
27450  common /tofev/ttvols
27451  common /secdr/iseor
27452  logical iseor, sseor
27453  common /mcs/imcs, ncstat, cstat(20)
27454  logical itvol, imamin, ichaes
27455  character *1 cr
27456  logical ialin
27457  dimension xmoy(20), ymoy(20), rmoy(20), rig(20), ncs(20)
27458  dimension xpmoy(20), ypmoy(20), avbt(20), charge(20), alp(20)
27459  ! -----------------------------------------------------------------
27460  ! print out on terminal of transport element # on one and the same line
27461  nrtre = nrtre + 1
27462  cr = char(13)
27463  write (6, 8254) nrtre, nrres, cr
27464 8254 format ('Transport element:', i5, ' Accelerating element:', i5, a1, $)
27465  ! ---- save iseor in sseor
27466  sseor = iseor
27467  ! iseor = false ---> second ordre transport matrix not available for the deflector
27468  iseor = .false.
27469 
27470  read (in, *) nsector
27471  read (in, *) rm0, devtot, radii, elecf
27472  bd0 = vref/vl
27473  gd0 = sqrt(1.-bd0*bd0)
27474  gd0 = 1./gd0
27475  wt0 = gd0*xmat
27476  wt0c = (wt0-xmat)
27477  ! edr0: electric rigidity (kV)
27478  edr0 = wt0*bd0*bd0*1.e03/qst
27479  ! efd0: radial electric field (in kV/cm)
27480  efd0 = edr0/rm0
27481  edfnom = efd0
27482  if (elecf>=0.) efd0 = elecf
27483  write (16, 1020) rm0, devtot, radii, edr0, edfnom, efd0, wt0c
27484 1020 format (' ELECTROSTATIC DEFLECTOR************', /, ' BENDING RADIUS: ', e12.5, ' cm ', /, &
27485  ' BEND ANGLE: ', e12.5, ' deg', /, ' VERTICAL RADII OF CURVATURE: ', e12.5, ' cm', /, ' RIGIDITY: ', &
27486  e12.5, ' kV ', /, ' RADIAL ELECTRIC FIELD (nominal): ', e12.5, ' kV/cm', /, &
27487  ' RADIAL ELECTRIC FIELD (applied): ', e12.5, ' kV/cm', /, ' INPUT ENERGY: ', e12.5, ' MeV', /)
27488  if (ichaes) then
27489  write (16, *) '***** beam current: ', beamc, ' mA'
27490  if ((iscsp<3) .and. (ncstat>1)) then
27491  write (6, *) '****************************'
27492  write (6, 2748)
27493 2748 format (' CAUTION: In the case of multiple charge states', /, &
27494  ' HERSC and SCHERM can not be used for electrostatic bends')
27495  end if
27496  end if
27497  ! start prints in file 'short.data'
27498  findex = 1. + rm0/radii
27499  idav = idav + 1
27500  iitem(idav) = 21
27501  dav1(idav, 2) = devtot
27502  dav1(idav, 3) = rm0*10.
27503  dav1(idav, 5) = radii*10.
27504  dav1(idav, 6) = findex
27505  dav1(idav, 7) = edr0
27506  dav1(idav, 8) = efd0*0.1
27507  ! convert bend angle in rad
27508  devtot = devtot*pi/180.
27509  l = devtot*rm0
27510  dav1(idav, 1) = l*10.
27511  sdavtot = davtot
27512  davtot = davtot + l
27513  dav1(idav, 4) = davtot*10.
27514  ! --- space charge computation: nsector must be g.t. 1
27515  if (ichaes .and. (nsector==1)) nsector = 2
27516  devi = devtot/float(nsector)
27517  devr = devtot/float(nsector)
27518  ! ----------------------------------------------------------
27519  ! -- scl effective length for space charge computation
27520  ! scl is the path length of the C.T. over two following sectors
27521  scl = 2.*devi*rm0
27522  do ist = 1, ncstat
27523  rmoy(ist) = 0.
27524  rig(ist) = 0.
27525  alp(ist) = devi
27526  end do
27527  ! -------------------
27528  ! ---- nsector: number of sectors in the deflector
27529  do nsec = 1, nsector
27530  write (6, *) '********'
27531  write (6, *) ' deflector sector ', nsec
27532  xlsy = devi*rm0
27533  sdavtot = sdavtot + xlsy
27534  ! ------------------------------------------------------------
27535  ! --- nsctat: number of charge states in the beam
27536  do ist = 1, ncstat
27537  charge(ist) = cstat(ist)
27538  xmoy(ist) = 0.
27539  xpmoy(ist) = 0.
27540  ymoy(ist) = 0.
27541  ypmoy(ist) = 0.
27542  ncs(ist) = 0
27543  rig(ist) = 0.
27544  avbt(ist) = 0.
27545  do i = 1, ngood
27546  if (f(9,i)==charge(ist)) then
27547  xmoy(ist) = xmoy(ist) + f(2, i)
27548  ymoy(ist) = ymoy(ist) + f(4, i)
27549  xpmoy(ist) = xpmoy(ist) + f(3, i)
27550  ypmoy(ist) = ypmoy(ist) + f(5, i)
27551  gpai = f(7, i)/xmat
27552  bpai = sqrt(1.-1./(gpai*gpai))
27553  avbt(ist) = avbt(ist) + bpai
27554  ! electric rigidity (kV)
27555  rip = f(7, i)*bpai*bpai/f(9, i)*1.e03
27556  rig(ist) = rip + rig(ist)
27557  ncs(ist) = ncs(ist) + 1
27558  end if
27559  end do
27560  xmoy(ist) = xmoy(ist)/float(ncs(ist))
27561  ymoy(ist) = ymoy(ist)/float(ncs(ist))
27562  xpmoy(ist) = xpmoy(ist)/float(ncs(ist))
27563  ypmoy(ist) = ypmoy(ist)/float(ncs(ist))
27564  rig(ist) = rig(ist)/float(ncs(ist))
27565  rmoy(ist) = rig(ist)/efd0
27566  avbt(ist) = avbt(ist)/float(ncs(ist))
27567  ! dispersion in dp/p relative to the cog of the bunch
27568  gcog = sqrt(1.-avbt(ist)*avbt(ist))
27569  fdtot = 0.
27570  nii = 0
27571  do i = 1, ngood
27572  if (f(9,i)==charge(ist)) then
27573  gpai = f(7, i)/xmat
27574  bpai = sqrt(1.-1./(gpai*gpai))
27575  fd(i) = (gpai*bpai)/(gcog*avbt(ist))
27576  fdtot = fdtot + fd(i)
27577  nii = nii + 1
27578  end if
27579  end do
27580  fdtot = fdtot/float(nii)
27581  ! --- local deflector
27582  ! alp(ist): angle of the local deflector
27583  ! parametres kx2 and ky2
27584  ! eq.11
27585  oo1 = rm0 - rmoy(ist) + xmoy(ist)
27586  ! eq.10
27587  abet = oo1*sin(alp(ist))/rmoy(ist)
27588  abet = asin(abet)
27589  ! eq.12 (angle of the local central trajectory)
27590  alp(ist) = alp(ist) + abet
27591  ! eq.14 (field index)
27592  findex = 1. + rmoy(ist)/radii
27593  ! eq.15 (parameters kx, ky)
27594  kx2 = 3. - findex - avbt(ist)*avbt(ist)
27595  rmoy2 = rmoy(ist)*rmoy(ist)
27596  kx2 = kx2/rmoy2
27597  ky2 = (findex-1.)/rmoy2
27598  ! ---- Transport matrix
27599  devi = alp(ist)
27600  ailong = devi*rmoy(ist)
27601  l = ailong
27602  ! drad: horizontal deflector radius (cm)
27603  ! l: length of the central trajectory (cm)
27604  ! kx2, ky2: DIMENSIONLESS coefficients depending on the field indice
27605  ! avb: average relativistic beta
27606  avb = avbt(ist)
27607  drad = rmoy(ist)
27608  ! --- deflector matrix
27609  write (16, 4101) charge(ist), nsec, nsector, efd0, rig(ist), findex, kx2, ky2, rmoy(ist), devi*180./pi, ailong
27610 4101 format (/, ' **************************************', /, ' *CENTRAL TRAJECTORY for charge: ', f4.1, ' *', /, &
27611  ' **************************************', /, ' SECTOR: ', i4, ' SECTORS NUMBER: ', i5, /, &
27612  ' RADIAL FIELD: ', e12.5, ' kV*cm-1: ', /, ' RIGIDITY: ', e12.5, ' kV ', /, ' FIELD INDEX: ', e12.5, &
27613  ' PARAMETER Kx: ', e12.5, ' cm-2 PARAMETER Ky: ', e12.5, ' cm-2', /, ' BENDING RADIUS: ', e12.5, ' cm ', &
27614  ' BENDING ANGLE: ', e12.5, ' deg', /, ' LENGTH: ', e12.5, ' cm', /)
27615  ! CLEAR R AND T
27616  call clear
27617  call deflect(fdtot)
27618  ! --- :print the transport matrix
27619  call matrix
27620  r51 = r(5, 1)
27621  ! ---- transport of particles
27622  do ii = 1, ngood
27623  if (f(9,ii)==charge(ist)) then
27624  call cobeam(ii, l)
27625  end if
27626  end do
27627  ! -------------------------------------------------------------------------
27628  ! --- get back the particles coordinates in the coordinates system of the synchronous particle
27629  ! eq.33
27630  ec = -rmoy(ist)*cos(abet) - oo1*sin(devi) + rm0
27631  do ii = 1, ngood
27632  if (f(9,ii)==charge(ist)) then
27633  ! eq.36
27634  f(2, ii) = f(2, ii)*cos(abet) - ec
27635  ! eq.41
27636  f(3, ii) = f(3, ii) - abet*1.e03
27637  ! eq.45
27638  gpai = f(7, ii)/xmat
27639  bpai = sqrt(1.-1./(gpai*gpai))
27640  f(6, ii) = f(6, ii) + r51*xmoy(ist)/(bpai*vl)
27641  end if
27642  end do
27643  ! enddo for ist (number of charges in the beam)
27644  end do
27645  ! --------------------------------------------------------------
27646  ! Space charge computation
27647  if (ichaes) then
27648  ! --- check the parity of nsec
27649  pnsec = float(nsec)/2. - nsec/2
27650  ! nsec is odd:---> space charge computation
27651  if ((pnsec/=0.) .and. (nsec<nsector)) then
27652  call cesp(scl)
27653  write (6, *) ' space charge after sector: ', nsec
27654  end if
27655  end if
27656  ! ------------------------------------------------------------
27657  ! enveloppe
27658  call stapl(sdavtot*10.)
27659  ! enddo for nsec (sectors numbers)
27660  end do
27661  ! ------------------------------------------------------
27662  ! random error in alignment
27663  if (ialin) call randali
27664  ! Change the dispersion dE/E with respect to the C.O.G of the bunch
27665  call disp
27666  call cogetc
27667  ! --- Test window after the bending magnet
27668  tcog = 0.
27669  gcog = 0.
27670  do i = 1, ngood
27671  gcog = gcog + f(7, i)/xmat
27672  tcog = tcog + f(6, i)
27673  end do
27674  tcog = tcog/float(ngood)
27675  gcog = gcog/float(ngood)
27676  bcog = sqrt(1.-1./(gcog*gcog))
27677  wcg = (gcog-1.)*xmat
27678  ! devtot: total angle of the deflector (computation of tref)
27679  devi = devtot
27680  ailong = devi*rm0
27681  tref = tref + ailong/vref
27682  ! ----- window control
27683  call reject(ilost)
27684  ! ---------------------------------------------------
27685  dav1(idav, 36) = ngood
27686  if (itvol) ttvols = tref
27687  if (itvol) write (16, *) ' tof for adjustments: ', ttvols, ' sec'
27688  if (iemgrw) call emiprt(0)
27689  ! old CALL STAPL(davtot*10.)
27690  ! ---- restore iseor (from sseor)
27691  iseor = sseor
27692  return
27693  end subroutine e_deflec
27694  ! *******************************************************************
27695  ! SUBROUTINE cesp(xlqua)
27696  ! select the space charge method (optical lenses)
27697  ! *******************************************************************
27698  subroutine cesp(xlqua)
27699  implicit real *8(a-h, o-z)
27700  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27701  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
27702  common /cdek/dwp(iptsz)
27703  common /dcspa/iesp
27704  common /faisc/f(10, iptsz), imax, ngood
27705  common /mcs/imcs, ncstat, cstat(20)
27706  logical ichaes, iesp, isepa
27707 
27708  do i = 1, ngood
27709  dwp(i) = 0.
27710  end do
27711  ! Space charge
27712  scdist = 0.
27713  if (.not. ichaes) return
27714  ! XLQUA: length of space charge effect
27715  if ((iscsp/=3) .and. (ncstat>1)) then
27716  write (6, *) '****************************'
27717  write (6, 2748)
27718 2748 format (' ERROR: Wrong space charge model chosen', /, ' With multiple charge states in the beam', /, &
27719  ' only the SCHEFF routine should be used')
27720  write (16, 2748)
27721  stop
27722  end if
27723  scdist = xlqua
27724  write (16, *) 'space charge length(cm): ', scdist
27725  iesp = .true.
27726  if (iscsp<=1) then
27727  ini = 1
27728  call hersc(ini)
27729  ini = 2
27730  call hersc(ini)
27731  end if
27732  if (iscsp==2) call schermi
27733  if (iscsp==3) then
27734  if (ncstat==1) call scheff1(1)
27735  ! --- otherwise: ncstat > 1 check if the bunches are separated or not
27736  if (ncstat>1) then
27737  isepa = .false.
27738  call b_sep(isepa)
27739  ! isepa = true call special scheff --->scheff_sep
27740  ! isepa = false call usual scheff ----> scheff1(1)
27741  if (isepa) call scheff_sep
27742  if (.not. isepa) call scheff1(1)
27743  end if
27744  end if
27745  return
27746  end subroutine cesp
27747  ! *******************************************************************
27748  ! SUBROUTINE sizer(ist,xrms,yrms,zrms)
27749  ! partial R.M.S. (called by SCHEFF_sep)
27750  ! *******************************************************************
27751  subroutine sizer(ist, xrms, yrms, zrms)
27752  implicit real *8(a-h, o-z)
27753  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27754  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
27755  common /cgrms/xsum, ysum, zsum
27756  common /faisc/f(10, iptsz), imax, ngood
27757  common /mcs/imcs, ncstat, cstat(20)
27758 
27759  xsum = 0.
27760  ysum = 0.
27761  zsum = 0.
27762  xsqsum = 0.
27763  ysqsum = 0.
27764  zsqsum = 0.
27765  ngist = 0
27766  do i = 1, ngood
27767  if (f(9,i)==cstat(ist)) then
27768  ngist = ngist + 1
27769  xsum = xsum + xc(i)
27770  ysum = ysum + yc(i)
27771  zsum = zsum + zc(i)
27772  xsqsum = xsqsum + xc(i)*xc(i)
27773  ysqsum = ysqsum + yc(i)*yc(i)
27774  zsqsum = zsqsum + zc(i)*zc(i)
27775  end if
27776  end do
27777  xsum = xsum/float(ngist)
27778  ysum = ysum/float(ngist)
27779  zsum = zsum/float(ngist)
27780  xsqsum = xsqsum/float(ngist)
27781  ysqsum = ysqsum/float(ngist)
27782  zsqsum = zsqsum/float(ngist)
27783  xrms = sqrt(xsqsum-xsum*xsum)
27784  yrms = sqrt(ysqsum-ysum*ysum)
27785  zrms = sqrt(zsqsum-zsum*zsum)
27786  return
27787  end subroutine sizer
27788  ! *******************************************************************
27789  ! SUBROUTINE pintim1(ist)
27790  ! Shifts particle coordinates to a single point in time. Uses
27791  ! a linear shift
27792  ! Divide by 100. to convert from cm to meters
27793  ! called by SCHEFF or SCHERM
27794  ! *******************************************************************
27795  subroutine pintim1(ist)
27796  implicit real *8(a-h, o-z)
27797  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27798  common /faisc/f(10, iptsz), imax, ngood
27799  common /qmoyen/qmoy
27800  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
27801  common /consta/vl, pi, xmat, rpel, qst
27802  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
27803  common /azlist/icont, iprin
27804  common /mcs/imcs, ncstat, cstat(20)
27805 
27806  grmoy = 0.
27807  trmoy = 0.
27808  xbax = 0.
27809  ngist = 0
27810  do i = 1, ngood
27811  if (f(9,i)==cstat(ist)) then
27812  ngist = ngist + 1
27813  grmoy = grmoy + f(7, i)/xmat
27814  trmoy = trmoy + f(6, i)
27815  xbax = xbax + f(2, i)
27816  end if
27817  end do
27818  trmoy = trmoy/float(ngist)
27819  grmoy = grmoy/float(ngist)
27820  brmoy = sqrt(1.-1./(grmoy*grmoy))
27821  xbax = xbax/float(ngist)
27822  ! ccc apl=0.
27823  ! Isochronism correction (bending magnet) only with SCHERM
27824  ! does not work with with SCHEFF (iscsp=3)
27825  ! ccc if(iscsp.eq.2) then
27826  ! ccc xb2x=0.
27827  ! ccc xb2z=0.
27828  ! ccc xbxz=0.
27829  ! ccc do np=1,ngood
27830  ! ccc gpai=f(7,np)/xmat
27831  ! ccc bpai=sqrt(1.-1./(gpai*gpai))
27832  ! ccc zc(np)=(trmoy-f(6,np))*bpai*vl/100.
27833  ! ccc xc(np)=(f(2,np)-xbax)/100.
27834  ! ccc xb2z=xb2z+zc(np)*zc(np)
27835  ! ccc xb2x=xb2x+xc(np)*xc(np)
27836  ! ccc xbxz=xbxz+zc(np)*xc(np)
27837  ! ccc enddo
27838  ! ccc xb2z=xb2z/float(ngood)
27839  ! ccc xb2x=xb2x/float(ngood)
27840  ! ccc xbxz=xbxz/float(ngood)
27841  ! ccc apl=atan(-2.*xbxz/(xb2x-xb2z))/2.
27842  ! ccc write(16,*) 'slope of the bunch in plane(Oz,Ox):',apl,' radian'
27843  ! ccc endif
27844  do np = 1, ngood
27845  if (f(9,np)==cstat(ist)) then
27846  gpai = f(7, np)/xmat
27847  bpai = sqrt(1.-1./(gpai*gpai))
27848  ! iscsp = 3 Lorentz transformation (only with scheff)
27849  ! omment if(iscsp.eq.3) znp=(trmoy-f(6,np))*bpai*vl*grmoy
27850  ! omment if(iscsp.eq.2) znp=(trmoy-f(6,np))*bpai*vl
27851  znp = (trmoy-f(6,np))*bpai*vl
27852  xnp = f(2, np)
27853  zc(np) = znp*cos(apl) + xnp*sin(apl)
27854  xnp = xnp*cos(apl) - znp*sin(apl)
27855  ! convert from mrad to rad
27856  f3 = f(3, np)*1.e-03
27857  f5 = f(5, np)*1.e-03
27858  ! convert from cm to m
27859  xc(np) = (xnp+zc(np)*f3)/100.
27860  yc(np) = (f(4,np)+zc(np)*f5)/100.
27861  zc(np) = zc(np)/100.
27862  end if
27863  end do
27864  xbar = 0.
27865  ybar = 0.
27866  zbar = 0.
27867  do np = 1, ngood
27868  ! evaluate xbar , ybar , zbar
27869  if (f(9,np)==cstat(ist)) then
27870  xbar = xbar + xc(np)
27871  ybar = ybar + yc(np)
27872  zbar = zbar + zc(np)
27873  end if
27874  end do
27875  xbar = xbar/float(ngist)
27876  ybar = ybar/float(ngist)
27877  zbar = zbar/float(ngist)
27878  ! Translate distribution by center of mass coordinates to shift
27879  ! coordinate origin to (0,0,0)
27880  do np = 1, ngood
27881  if (f(9,np)==cstat(ist)) then
27882  xc(np) = xc(np) - xbar
27883  yc(np) = yc(np) - ybar
27884  zc(np) = zc(np) - zbar
27885  end if
27886  end do
27887  return
27888  end subroutine pintim1
27889  ! *******************************************************************
27890  ! SUBROUTINE b_sep(isepa)
27891  ! check if the bunches in the beam are separated or not
27892  ! *******************************************************************
27893  subroutine b_sep(isepa)
27894  implicit real *8(a-h, o-z)
27895  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
27896  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
27897  common /cgrms/xsum, ysum, zsum
27898  common /faisc/f(10, iptsz), imax, ngood
27899  common /mcs/imcs, ncstat, cstat(20)
27900  common /consta/vl, pi, xmat, rpel, qst
27901  dimension d11(2), d22(2), d12(2), rp12(2), xpint(2), xint(2)
27902  logical isepa
27903 
27904  csmax1 = 0.
27905  icms1 = 0
27906  do i = 1, ncstat
27907  if (cstat(i)>csmax1) then
27908  icsm1 = i
27909  csmax1 = cstat(i)
27910  end if
27911  end do
27912  csmax2 = 0.
27913  do i = 1, ncstat
27914  if (i/=icsm1) then
27915  if (cstat(i)>csmax2) then
27916  csmax2 = cstat(i)
27917  end if
27918  end if
27919  end do
27920  xg1 = 0.
27921  xpg1 = 0.
27922  xg2 = 0.
27923  xpg2 = 0.
27924  imax1 = 0
27925  imax2 = 0
27926  ! COG over state charges csmax1 and csmax2
27927  do i = 1, ngood
27928  if (f(9,i)==csmax1) then
27929  xg1 = xg1 + f(2, i)
27930  xpg1 = xpg1 + f(3, i)
27931  imax1 = imax1 + 1
27932  end if
27933  if (f(9,i)==csmax2) then
27934  xg2 = xg2 + f(2, i)
27935  xpg2 = xpg2 + f(3, i)
27936  imax2 = imax2 + 1
27937  end if
27938  end do
27939  xg1 = xg1/float(imax1)
27940  xpg1 = xpg1/float(imax1)
27941  xg2 = xg2/float(imax2)
27942  xpg2 = xpg2/float(imax2)
27943  ! ------------------------------------
27944  d11(1) = 0.
27945  d22(1) = 0.
27946  d12(1) = 0.
27947  d11(2) = 0.
27948  d22(2) = 0.
27949  d12(2) = 0.
27950  do i = 1, ngood
27951  if (f(9,i)==csmax1) then
27952  d11(1) = d11(1) + (f(3,i)-xpg1)**2
27953  d22(1) = d22(1) + (f(2,i)-xg1)**2
27954  d12(1) = d12(1) + (f(3,i)-xpg1)*(f(2,i)-xg1)
27955  end if
27956  if (f(9,i)==csmax2) then
27957  d11(2) = d11(2) + (f(3,i)-xpg2)**2
27958  d22(2) = d22(2) + (f(2,i)-xg2)**2
27959  d12(2) = d12(2) + (f(3,i)-xpg2)*(f(2,i)-xg2)
27960  end if
27961  end do
27962  d11(1) = d11(1)/float(imax1)
27963  d22(1) = d22(1)/float(imax1)
27964  d12(1) = d12(1)/float(imax1)
27965  d11(2) = d11(2)/float(imax2)
27966  d22(2) = d22(2)/float(imax2)
27967  d12(2) = d12(2)/float(imax2)
27968  rp12(1) = d12(1)/sqrt(d11(1)*d22(1))
27969  rp12(2) = d12(2)/sqrt(d11(2)*d22(2))
27970  xpint(1) = sqrt(d11(1)*(1.-rp12(1)))
27971  xint(1) = sqrt(d22(1)*(1.-rp12(1)))
27972  xpint(2) = sqrt(d11(2)*(1.-rp12(2)))
27973  xint(2) = sqrt(d22(2)*(1.-rp12(2)))
27974  ! ------------------------------------------------------------
27975  elip1 = xpg1 + xpint(1)
27976  elip2 = xpg2 - xpint(2)
27977  if (elip1<elip2) isepa = .true.
27978  ! TEST*********
27979  ! old write(6,*)'xpg1 xpint(1) elip1 ',xpg1,xpint(1),elip1
27980  ! old write(6,*)'xpg2 xpint(2) elip2 ',xpg2,xpint(2),elip2
27981  ! old write(6,*)'isepa ',isepa
27982  ! old write(6,*) ' ************************************'
27983  ! ***************************************************************
27984  return
27985  end subroutine b_sep
27986  ! *******************************************************************
27987  ! SUBROUTINE schefini
27988  ! Set up field tables for SCHEFF1 and SCHEFF_sep
27989  ! input data
27990  ! sce(2)=radial extension in rms multiples
27991  ! sce(3)=longitudinal extension in rms multiples
27992  ! sce(4)=no. of radial mesh intervals (le 20)
27993  ! sce(5)=no. of longitudinal mesh intervals (le 40)
27994  ! sce(6)=no. of adjacent bunches, applicable for buncher
27995  ! studies and should be 0 for linac dynamics
27996  ! sce(7)=distance between adjacent beam pulses in cm
27997  ! (transport studies); input zero to get (beta*lambda)
27998  ! default
27999  ! sce(8)=desactived
28000  ! sce(9)=option to integrate space charge forces over box
28001  ! if.eq.0. no integration see sub gaus for further
28002  ! explanation.
28003  ! sce(10) =1 : call in quads,solenoids,accelarating elements
28004  ! sce(10) =2 : call in drifts,accelarating elements
28005  ! sce(10) =3 : call at both
28006  ! standard SCHEFF parameters (see user guide)
28007  ! sce(2)=4
28008  ! sce(3)=4
28009  ! sce(4)=20
28010  ! sce(5)=40
28011  ! sce(6)=0
28012  ! sce(7)=0
28013  ! sce(9)=0
28014  ! *******************************************************************
28015  subroutine schefini
28016  implicit real *8(a-h, o-z)
28017  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28018  common /dyn/tref, vref
28019  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28020  common /consta/vl, pi, xmat, rpel, qst
28021  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
28022  common /faisc/f(10, iptsz), imax, ngood
28023  logical ichaes
28024  ! common modifiés *********************
28025  common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
28026  common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
28027  common /fldcom/rp, zp, pl, opt, nip
28028  ! ***********************************
28029  common /rcshef/sce(20)
28030  common /conti/irfqp
28031  logical irfqp
28032 
28033  gmoy = 0.
28034  do np = 1, ngood
28035  gmoy = f(7, np)/xmat + gmoy
28036  end do
28037  gmoy = gmoy/float(ngood)
28038  bgmoy = sqrt(gmoy*gmoy-1.)
28039  beams = beamc/1000.0
28040  wavel = 2.*pi*vl/fh
28041  freq = fh/(2.*pi)
28042  frrms = sce(2)
28043  fzrms = sce(3)
28044  nr = idint(sce(4))
28045  nz = idint(sce(5))
28046  nip = idint(sce(6))
28047  opt = sce(9)
28048  pl = bgmoy*wavel
28049  if (irfqp) pl = pl/2.
28050  ! sce(7)=pulse length, if not beta lambda.(transport studies), units are cm
28051  if (sce(7)>0.) pl = sce(7)*gmoy
28052  nr1 = nr + 1
28053  nz1 = nz + 1
28054  im1 = nr*nz
28055  im2 = nr1*nz1
28056  im3 = nr1*nz
28057  na = 1
28058  nb = ngood
28059  nq = nb - na + 1
28060  return
28061  end subroutine schefini
28062  ! *******************************************************************
28063  ! SUBROUTINE scheff1(idum)
28064  ! SCHEFF space charge method
28065  ! remark: In this version int is a dummy parameter
28066  ! This version of SCHEFF, starting from Swesson version, has
28067  ! modifications made to include corrections for relativistic beams.
28068  ! The dynamics have been modified to transform to the beam rest
28069  ! frame, calculate the space-charge kicks in this frame, and then
28070  ! transform back to the lab frame.
28071  ! input data
28072  ! sce(1)=beam current in ma.
28073  ! sce(2)=radial extension in rms multiples
28074  ! sce(3)=longitudinal extension in rms multiples
28075  ! sce(4)=no. of radial mesh intervals (le 20)
28076  ! sce(5)=no. of longitudinal mesh intervals (le 40)
28077  ! sce(6)=no. of adjacent bunches, applicable for buncher
28078  ! studies and should be 0 for linac dynamics
28079  ! sce(7)=distance between adjacent beam pulses in cm
28080  ! (transport studies); input zero to get (beta*lambda)
28081  ! default
28082  ! sce(8)=desactived
28083  ! sce(9)=option to integrate space charge forces over box
28084  ! if.eq.0. no integration see sub gaus for further
28085  ! explanation.
28086  ! sce(10) =1 : call in quads,solenoids,accelarating elements
28087  ! sce(10) =2 : call in drifts,accelarating elements
28088  ! sce(10) =3 : call at both
28089  ! standard SCHEFF parameters (see sub schfdyn and user guide)
28090  ! sce(2)=4
28091  ! sce(3)=4
28092  ! sce(4)=20
28093  ! sce(5)=40
28094  ! sce(6)=0
28095  ! sce(7)=0
28096  ! sce(9)=0
28097  ! *******************************************************************
28098  subroutine scheff1(idum)
28099  implicit real *8(a-h, o-z)
28100  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28101  common /dyn/tref, vref
28102  common /cmpte/iell
28103  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
28104  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
28105  common /hermt/afxt(22), afyt(22), afzt(22)
28106  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28107  common /consta/vl, pi, xmat, rpel, qst
28108  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
28109  common /faisc/f(10, iptsz), imax, ngood
28110  common /cdek/dwp(iptsz)
28111  common /beamsa/fs(7, iptsz)
28112  common /dcspa/iesp
28113  common /compt/nrres, nrtre, nrbunc, nrdbun
28114  common /posc/xpsc
28115  logical ichaes, iesp
28116  common /bg/bsc, gsc, phis, wsync
28117  common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
28118  common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
28119  common /fldcom/rp, zp, pl, opt, nip
28120  common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
28121  rss(20), ismax(40), iemax(41)
28122  common /rcshef/sce(20)
28123  common /conti/irfqp
28124  ! ********************************************
28125  ! v28/04/2015
28126  common /fcont/ifcont
28127  logical ifcont
28128  ! ********************************************
28129  logical irfqp
28130 
28131  idm = idum
28132  ! set up field tables with int=0
28133  ! omment beami=beamc/1000.0
28134  ! ********************************************
28135  ! v28/04/2015
28136  if (ifcont) then
28137  pib = 180.
28138  call compress(pib)
28139  end if
28140  ! ********************************************
28141  gmoy = 0.
28142  do np = 1, ngood
28143  gmoy = f(7, np)/xmat + gmoy
28144  end do
28145  gmoy = gmoy/float(ngood)
28146  beami = beams/gmoy
28147  if (beami==0. .or. scdist==0.) return
28148  iell = iell + 1
28149  ! write(16,*) ' *call SCHEFF ',iell
28150  call pintim
28151  ! write(16,*) ' *after pintim '
28152  call sizrms(0, xrms, yrms, zrms, zz)
28153  ! write(16,*) ' *after sizrms ',zz
28154  write (16, 6875) iell, xrms, yrms, zrms
28155  ! write the size rms in the output file 17
28156  ! omment write(17,25) iell,xrms,yrms,zrms
28157  ! omment25 format(2x,i5,3(2x,e12.5))
28158 6875 format (' Cell ', i4, ' RMS size(m)', e12.5, 2x, e12.5, 2x, e12.5)
28159  rrms = sqrt(xrms*xrms+yrms*yrms)
28160  ! change unit: m==>cm
28161  zrms1 = zrms*100.
28162  rrms = rrms*100.
28163  dr = rrms*frrms/float(nr)
28164  dz = zrms1*fzrms/float(nz)
28165  rmax = float(nr)*dr
28166  ! load rm, zm, rs, zs
28167  rm(1) = 0.0
28168  do i = 2, nr1
28169  rm(i) = float(i-1)*dr
28170  rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
28171  rss(i-1) = 0.5*(rm(i-1)+rm(i))
28172  rs(i-1) = sqrt(rssq(i-1))
28173  end do
28174  zs = .5*dz
28175  do i = 1, nz1
28176  zm(i) = float(i-1)*dz
28177  zzs(i) = zm(i) + zs
28178  end do
28179  hl = float(nz)*zs
28180  ! load ers and ezs
28181  ! mesh dimensions are in cm. ers and ezs are in 1/cm.
28182  ! c1, c2 and c3 are in cm., and c4 is in mev-cm.
28183  ! q=coulombs/point. (2/pi)*e/(4*pi*epsilon)=572167 cm mev/coul.
28184  q = beami/(freq*float(nq))
28185  c1 = 572167.*q/xmat
28186  l = 0
28187  do k = 1, nr
28188  rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
28189  if (opt==0.) rfac = 1.
28190  do j = 1, nz
28191  zp = zm(j+1)
28192  do i = 1, nr1
28193  rp = rm(i)
28194  if (opt==0.) call flds(rs(k), zs, er1, ez1)
28195  if (opt==0.) go to 35
28196  call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
28197 35 l = l + 1
28198  ers(l) = c1*er1/rfac
28199  ! cc write(16,*) ' ersl ',ers(l),' er1 ',er1,' l ',l
28200  ! cc write(16,*) ' rsk ',rs(k),' k ',k,' zs ',zs
28201  ! cc pause
28202  ezs(l) = c1*ez1/rfac
28203  end do
28204  end do
28205  end do
28206  if (beamc==0. .or. scdist==0.) return
28207  dz1 = scdist/100.
28208  dist = scdist
28209  ! sup WRITE(16, *) ' fields acting length(cm): ',DIST
28210  ! evaluate and apply space charge effects.
28211  ! phimc=phi of mesh center.
28212  ! Shifts particle coordinates to a single point in time. Uses
28213  ! a linear shift
28214  ! Beam c.g.
28215  xbar = 0.
28216  ybar = 0.
28217  zbar = 0.
28218  brmoy = 0.
28219  trmoy = 0.
28220  do np = 1, ngood
28221  gpai = f(7, np)/xmat
28222  brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
28223  trmoy = trmoy + f(6, np)
28224  end do
28225  trmoy = trmoy/float(ngood)
28226  phimc = trmoy*fh
28227  pbar = phimc
28228  beta = brmoy/float(ngood)
28229  gsc = 1./sqrt(1.-beta*beta)
28230  bg = beta*gsc
28231  c3 = dist/bg
28232  c4 = dist*xmat
28233  ! evaluate ng, xbar, ybar, and pbar.
28234  c2 = beta*wavel/(2.*pi)
28235  gmsq = 1. + bg**2
28236  gam = sqrt(gmsq)
28237  ! evaluate ng, xbar, ybar
28238  ng = 0
28239  xbar = 0.
28240  ybar = 0.
28241  xsq = 0.
28242  ysq = 0.
28243  do np = 1, ngood
28244  ng = ng + 1
28245  x = f(2, np)
28246  y = f(4, np)
28247  xf = f(3, np)
28248  yf = f(5, np)
28249  xbar = xbar + x
28250  ybar = ybar + y
28251  xsq = xsq + x**2
28252  ysq = ysq + y**2
28253  end do
28254  eng = float(ngood)
28255  xbar = xbar/eng
28256  ybar = ybar/eng
28257  ! the mesh center is phi*syn
28258  xsq = xsq/eng
28259  ysq = ysq/eng
28260  epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
28261  epsqi = 1./epsq
28262  xfac = 2./(epsq+1.)
28263  yfac = epsq*xfac
28264  ! clear and load bins
28265  ng = 0
28266  do i = 1, im1
28267  aa(i) = 0.0
28268  end do
28269  do np = 1, ngood
28270  rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
28271  ! i=sqrt(rsq)/dr+1.
28272  r = sqrt(rsq)
28273  halfdr = dr*0.5
28274  i = idint(r/dr+1.0)
28275  if (i>nr) go to 120
28276  zph = f(6, np)*fh
28277  z = -c2*(zph-phimc)
28278  if (abs(z)>=hl) go to 120
28279  ! ------distribute charge among adjacent bins.
28280  ng = ng + 1
28281  zz = z + hl
28282  jm1 = idint(zz/dz+1.)
28283  i1 = i + 1
28284  ! if (rsq.lt.rssq(i)) i1=i-1
28285  if (rsq<rss(i)) i1 = i - 1
28286  if (i1<1) i1 = 1
28287  if (i1>nr) i1 = nr
28288  j1 = jm1 + 1
28289  if (zz<zzs(jm1)) j1 = jm1 - 1
28290  if (j1<1) j1 = 1
28291  if (j1>nz) j1 = nz
28292  a = 1.
28293  ! if (i1.ne.i) a=(rsq-rssq(i1))/(rssq(i)-rssq(i1))
28294  if (i1==i) then
28295  a = 1.
28296  else
28297  rdr2 = rsq/dr**2
28298  sqr = sqrt(4.*rdr2-1.)
28299  rminsq = (halfdr*(sqr-1.))**2
28300  rmaxsq = (halfdr*(sqr+1.))**2
28301  if (i1<i) then
28302  a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
28303  else
28304  a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
28305  end if
28306  end if
28307  ! omment if (r.gt.halfdr)then
28308  ! omment rminsq=(r-halfdr)**2
28309  ! omment rmaxsq=(r+halfdr)**2
28310  ! omment if (i1.lt.i) then
28311  ! omment a=(rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
28312  ! omment else
28313  ! omment a=(rm(i1)**2-rminsq)/(rmaxsq-rminsq)
28314  ! omment endif
28315  ! omment endif
28316  b = 1. - a
28317  cc = 1.
28318  if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
28319  d = 1. - cc
28320  k = (jm1-1)*nr + i
28321  aa(k) = aa(k) + a*cc
28322  k = k + i1 - i
28323  aa(k) = aa(k) + b*cc
28324  k = (j1-1)*nr + i
28325  aa(k) = aa(k) + a*d
28326  k = k + i1 - i
28327  aa(k) = aa(k) + b*d
28328 120 end do
28329  eng = float(ng)
28330  do j = 1, nz
28331  l = (j-1)*nr
28332  k = nr
28333  do i = 1, nr
28334  m = l + k
28335  if (aa(m)<=0.00) then
28336  k = k - 1
28337  go to 130
28338  else
28339  go to 140
28340  end if
28341 130 continue
28342  end do
28343 140 ismax(j) = k
28344  end do
28345  ! find iemax for each j
28346  iemax(1) = 1 + ismax(1)
28347  do j = 2, nz
28348  iemax(j) = 1 + max0(ismax(j-1), ismax(j))
28349  end do
28350  iemax(nz1) = 1 + ismax(nz)
28351  ! set er and ez to zero
28352  do i = 1, im2
28353  er(i) = 0.0
28354  ez(i) = 0.0
28355  end do
28356  ! sum up fields
28357  do js = 1, nz
28358  js1 = js + 1
28359  ism = ismax(js)
28360  if (ism==0) go to 220
28361  do is = 1, ism
28362  l = (js-1)*nr + is
28363  a1 = aa(l)
28364  if (a1==0.) go to 210
28365  l = (is-1)*im3
28366  do je = 1, js
28367  k1 = l + (js-je)*nr1
28368  n1 = (je-1)*nr1
28369  iem = iemax(je)
28370  if (iem<=1) go to 180
28371  do ie = 1, iem
28372  n = n1 + ie
28373  k = k1 + ie
28374  er(n) = er(n) + a1*ers(k)
28375  ez(n) = ez(n) - a1*ezs(k)
28376  end do
28377 180 end do
28378  do je = js1, nz1
28379  k1 = l + (je-js1)*nr1
28380  n1 = (je-1)*nr1
28381  iem = iemax(je)
28382  if (iem<=1) go to 200
28383  do ie = 1, iem
28384  n = n1 + ie
28385  k = k1 + ie
28386  er(n) = er(n) + a1*ers(k)
28387  ez(n) = ez(n) + a1*ezs(k)
28388  end do
28389 200 end do
28390 210 end do
28391 220 end do
28392  ! evaluate and apply impulse
28393  rrmax = 0.
28394  zzmax = 0.
28395  zzmin = 1000.
28396  npz = 0
28397  npr = 0
28398  do np = 1, ngood
28399 
28400  ! Transforming to the bunch reference frame
28401 
28402  dwc = f(7, np) - xmat
28403  gm1 = dwc/xmat
28404  ! convert xp an yp from mrad to rad
28405  f3np = f(3, np)*1.e-03
28406  f5np = f(5, np)*1.e-03
28407  ! omment gm1*(2.+gm1)=(gam-1)*(gam+1)=gam*gam-1=beta*beta*gam*gam
28408  bgz = sqrt(gm1*(2.+gm1))
28409  bgx = bgz*f3np
28410  bgy = bgz*f5np
28411  gamma = 1. + gm1
28412  ! Particle momentum in the bunch frame
28413 
28414  bgzstar = gam*(bgz-beta*gamma)
28415 
28416  ! Particle energy in bunch frame
28417 
28418  gstar = gam*(gamma-beta*bgz)
28419 
28420  r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
28421  if (r>=rrmax) rrmax = r
28422  if (r==0.) r = .000001
28423  xor = (f(2,np)-xbar)*xfac/r
28424  yor = (f(4,np)-ybar)*yfac/r
28425  if (r>rmax) then
28426  npr = npr + 1
28427  go to 230
28428  end if
28429  zph = f(6, np)*fh
28430  z = -c2*(zph-phimc)
28431  if (z>=zzmax) zzmax = z
28432  if (z<zzmin) zzmin = z
28433  if (abs(z)>hl) then
28434  npz = npz + 1
28435  go to 230
28436  end if
28437  ! interpolate impulse within mesh.
28438  rb = r/dr
28439  i = idint(1.+rb)
28440  a = rb - float(i-1)
28441  b = 1. - a
28442  zb = (z+hl)/dz
28443  j = idint(1.+zb)
28444  c = zb - float(j-1)
28445  d = 1. - c
28446  l = i + (j-1)*nr1
28447  m = l + nr1
28448  cbgr = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
28449  cbgzs = c3*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
28450  ! *******************
28451  ! cc write(14,5755)np,cbgr,cbgzs,c3,a,b,c,d
28452  ! cc write(14,5755)np,l,m,er(l+1),er(l),er(m+1),er(m)
28453  ! cc5755 format(2x,i5,7(2x,e12.5))
28454  ! cc5755 format(3(2x,i5),4(2x,e12.5))
28455  ! *******************
28456  ! different space charge in the bunch (valero)
28457  cbgr = cbgr*abs(f(9,np))
28458  cbgzs = cbgzs*abs(f(9,np))
28459  go to 260
28460  ! estimate impulse based on point charge at xbar,ybar,pbar.
28461  ! estimate impulse based on point charge at xbar,ybar,pbar.
28462 230 continue
28463  d = sqrt(z**2+r**2)
28464  rod3 = r/d**3
28465  zod3 = z/d**3
28466  if (nip==0) go to 250
28467  ! include neighboring bunches.
28468  do i = 1, nip
28469  xi = i
28470  do j = 1, 2
28471  s = z + xi*pl
28472  d = sqrt(s**2+r**2)
28473  rod3 = rod3 + r/d**3
28474  zod3 = zod3 + s/d**3
28475  xi = -xi
28476  end do
28477  end do
28478  ! Evaluate impulse.
28479 
28480 250 cbgr = eng*c1*c3*rod3*pi/2.
28481  cbgzs = eng*c1*c3*zod3*pi/2.
28482  ! different charges in the bunch (valero)
28483  cbgr = cbgr*abs(f(9,np))
28484  cbgzs = cbgzs*abs(f(9,np))
28485 
28486  ! Apply impulse and transform back to lab frame.
28487 
28488 260 bgx = bgx + cbgr*xor
28489  bgy = bgy + cbgr*yor
28490  pbgzstar = bgzstar
28491  bgzstar = bgzstar + cbgzs
28492  gstar = 1. + 0.5*bgzstar**2
28493  bgzf = gam*(bgzstar+beta*gstar)
28494  f3 = bgx/bgzf
28495  f5 = bgy/bgzf
28496  dww = f(7, np) - xmat
28497  dws = dww*((gamma+1.)/gamma)*(bgzf-bgz)/bgz
28498  ! cc write(14,5755)np,pbgzstar,cbgzs,bgzstar
28499  ! cc5755 format(2x,i5,3(2x,e12.5))
28500  ! ********************
28501  if (.not. iesp) then
28502  ! load the entrance beam parameters for cavities or gaps
28503  do js = 1, 7
28504  f(js, np) = fs(js, np)
28505  end do
28506  ! dxp and dyp are the jumps of xp and yp (in rad) at the position dz1*xpsc (in m)
28507  dxp = f3 - f3np
28508  dyp = f5 - f5np
28509  ! correction of xp and yp ( in rad)
28510  f(3, np) = f(3, np) + dxp*1000.
28511  f(5, np) = f(5, np) + dyp*1000.
28512  f(2, np) = f(2, np) - dz1*100.*dxp*xpsc
28513  f(4, np) = f(4, np) - dz1*100.*dyp*xpsc
28514  dwp(np) = dws
28515  else
28516  f(3, np) = f3*1000.
28517  f(5, np) = f5*1000.
28518  f(7, np) = f(7, np) + dws
28519  end if
28520  end do
28521  return
28522  end subroutine scheff1
28523  ! *******************************************************************
28524  ! SUBROUTINE scheff_sep
28525  ! SCHEFF_sep special space charge method
28526  ! This version of SCHEFF, starting from Swesson version, has
28527  ! modifications made to include corrections for relativistic beams.
28528  ! The dynamics have been modified to transform to the beam rest
28529  ! frame, calculate the space-charge kicks in this frame, and then
28530  ! transform back to the lab frame.
28531  ! input data
28532  ! sce(1)=beam current in ma.
28533  ! sce(2)=radial extension in rms multiples
28534  ! sce(3)=longitudinal extension in rms multiples
28535  ! sce(4)=no. of radial mesh intervals (le 20)
28536  ! sce(5)=no. of longitudinal mesh intervals (le 40)
28537  ! sce(6)=no. of adjacent bunches, applicable for buncher
28538  ! studies and should be 0 for linac dynamics
28539  ! sce(7)=distance between adjacent beam pulses in cm
28540  ! (transport studies); input zero to get (beta*lambda)
28541  ! default
28542  ! sce(8)=desactived
28543  ! sce(9)=option to integrate space charge forces over box
28544  ! if.eq.0. no integration see sub gaus for further
28545  ! explanation.
28546  ! sce(10) =1 : call in quads,solenoids,accelarating elements
28547  ! sce(10) =2 : call in drifts,accelarating elements
28548  ! sce(10) =3 : call at both
28549  ! standard SCHEFF parameters (see sub schfdyn and user guide)
28550  ! sce(2)=4
28551  ! sce(3)=4
28552  ! sce(4)=20
28553  ! sce(5)=40
28554  ! sce(6)=0
28555  ! sce(7)=0
28556  ! sce(9)=0
28557  ! *******************************************************************
28558  subroutine scheff_sep
28559  implicit real *8(a-h, o-z)
28560  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28561  common /dyn/tref, vref
28562  common /cmpte/iell
28563  common /part/xc(iptsz), yc(iptsz), zc(iptsz)
28564  common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
28565  common /hermt/afxt(22), afyt(22), afzt(22)
28566  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28567  common /consta/vl, pi, xmat, rpel, qst
28568  common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
28569  common /faisc/f(10, iptsz), imax, ngood
28570  common /cdek/dwp(iptsz)
28571  common /beamsa/fs(7, iptsz)
28572  common /dcspa/iesp
28573  common /compt/nrres, nrtre, nrbunc, nrdbun
28574  common /posc/xpsc
28575  logical ichaes, iesp
28576  common /bg/bsc, gsc, phis, wsync
28577  common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
28578  common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
28579  common /fldcom/rp, zp, pl, opt, nip
28580  common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
28581  rss(20), ismax(40), iemax(41)
28582  common /rcshef/sce(20)
28583  common /mcs/imcs, ncstat, cstat(20)
28584  common /conti/irfqp
28585  logical irfqp
28586  ! set up field tables with int=0
28587  if (beams==0. .or. scdist==0.) return
28588  ! isepa true ---> the ncstat bunches are separated
28589  iell = iell + 1
28590  write (16, *) ' ****SCHEFF ', iell
28591  write (16, *) ' states charges ', ncstat
28592  do isp = 1, ncstat
28593  ngisp = 0
28594  gmoy = 0.
28595  do np = 1, ngood
28596  if (f(9,np)==cstat(isp)) then
28597  ngisp = ngisp + 1
28598  gmoy = f(7, np)/xmat + gmoy
28599  end if
28600  end do
28601  gmoy = gmoy/float(ngisp)
28602  ! old beamc=beams/ncstat
28603  beamc = beams*ngisp/ngood
28604  beami = beamc/gmoy
28605  call pintim1(isp)
28606  call sizer(isp, xrms, yrms, zrms)
28607  write (16, 6875) cstat(isp), beamc, xrms, yrms, zrms
28608  ! write the size rms in the output file 17
28609  ! old write(17,25) iell,xrms,yrms,zrms
28610  ! old25 format(2x,i5,3(2x,e12.5))
28611 6875 format (' charge: ', f8.0, ' bunch intensity: ', e12.5, ' amp', /, ' with RMS size(m)', e12.5, 2x, e12.5, 2x, &
28612  e12.5)
28613  rrms = sqrt(xrms*xrms+yrms*yrms)
28614  ! change unit: m==>cm
28615  zrms1 = zrms*100.
28616  rrms = rrms*100.
28617  dr = rrms*frrms/float(nr)
28618  dz = zrms1*fzrms/float(nz)
28619  rmax = float(nr)*dr
28620  ! load rm, zm, rs, zs
28621  rm(1) = 0.0
28622  do i = 2, nr1
28623  rm(i) = float(i-1)*dr
28624  rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
28625  rss(i-1) = 0.5*(rm(i-1)+rm(i))
28626  rs(i-1) = sqrt(rssq(i-1))
28627  end do
28628  zs = .5*dz
28629  do i = 1, nz1
28630  zm(i) = float(i-1)*dz
28631  zzs(i) = zm(i) + zs
28632  end do
28633  hl = float(nz)*zs
28634  ! load ers and ezs
28635  ! mesh dimensions are in cm. ers and ezs are in 1/cm.
28636  ! c1, c2 and c3 are in cm., and c4 is in mev-cm.
28637  ! q=coulombs/point. (2/pi)*e/(4*pi*epsilon)=572167 cm mev/coul.
28638  q = beami/(freq*float(nq))
28639  c1 = 572167.*q/xmat
28640  l = 0
28641  do k = 1, nr
28642  rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
28643  if (opt==0.) rfac = 1.
28644  do j = 1, nz
28645  zp = zm(j+1)
28646  do i = 1, nr1
28647  rp = rm(i)
28648  if (opt==0.) call flds(rs(k), zs, er1, ez1)
28649  if (opt==0.) go to 35
28650  call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
28651 35 l = l + 1
28652  ers(l) = c1*er1/rfac
28653  ezs(l) = c1*ez1/rfac
28654  end do
28655  end do
28656  end do
28657  dz1 = scdist/100.
28658  dist = scdist
28659  ! sup WRITE(16, *) ' fields acting length(cm): ',DIST
28660  ! evaluate and apply space charge effects.
28661  ! phimc=phi of mesh center.
28662  ! Shifts particle coordinates to a single point in time. Uses
28663  ! a linear shift
28664  ! Beam c.g.
28665  xbar = 0.
28666  ybar = 0.
28667  zbar = 0.
28668  brmoy = 0.
28669  trmoy = 0.
28670  do np = 1, ngood
28671  if (f(9,np)==cstat(isp)) then
28672  gpai = f(7, np)/xmat
28673  brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
28674  trmoy = trmoy + f(6, np)
28675  end if
28676  end do
28677  trmoy = trmoy/float(ngisp)
28678  phimc = trmoy*fh
28679  pbar = phimc
28680  beta = brmoy/float(ngisp)
28681  gsc = 1./sqrt(1.-beta*beta)
28682  bg = beta*gsc
28683  c3 = dist/bg
28684  c4 = dist*xmat
28685  ! evaluate ng, xbar, ybar, and pbar.
28686  c2 = beta*wavel/(2.*pi)
28687  gmsq = 1. + bg**2
28688  gam = sqrt(gmsq)
28689  ! evaluate ng, xbar, ybar
28690  ng = 0
28691  xbar = 0.
28692  ybar = 0.
28693  xsq = 0.
28694  ysq = 0.
28695  do np = 1, ngood
28696  if (f(9,np)==cstat(isp)) then
28697  ng = ng + 1
28698  x = f(2, np)
28699  y = f(4, np)
28700  xf = f(3, np)
28701  yf = f(5, np)
28702  xbar = xbar + x
28703  ybar = ybar + y
28704  xsq = xsq + x**2
28705  ysq = ysq + y**2
28706  end if
28707  end do
28708  eng = float(ngisp)
28709  xbar = xbar/eng
28710  ybar = ybar/eng
28711  ! the mesh center is phi*syn
28712  xsq = xsq/eng
28713  ysq = ysq/eng
28714  epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
28715  epsqi = 1./epsq
28716  xfac = 2./(epsq+1.)
28717  yfac = epsq*xfac
28718  ! clear and load bins
28719  ng = 0
28720  do i = 1, im1
28721  aa(i) = 0.0
28722  end do
28723  do np = 1, ngood
28724  if (f(9,np)==cstat(isp)) then
28725  rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
28726  ! i=sqrt(rsq)/dr+1.
28727  r = sqrt(rsq)
28728  halfdr = dr*0.5
28729  i = idint(r/dr+1.0)
28730  if (i>nr) go to 120
28731  zph = f(6, np)*fh
28732  z = -c2*(zph-phimc)
28733  if (abs(z)>=hl) go to 120
28734  ! ------distribute charge among adjacent bins.
28735  ng = ng + 1
28736  zz = z + hl
28737  jm1 = idint(zz/dz+1.)
28738  i1 = i + 1
28739  ! if (rsq.lt.rssq(i)) i1=i-1
28740  if (rsq<rss(i)) i1 = i - 1
28741  if (i1<1) i1 = 1
28742  if (i1>nr) i1 = nr
28743  j1 = jm1 + 1
28744  if (zz<zzs(jm1)) j1 = jm1 - 1
28745  if (j1<1) j1 = 1
28746  if (j1>nz) j1 = nz
28747  a = 1.
28748  ! if (i1.ne.i) a=(rsq-rssq(i1))/(rssq(i)-rssq(i1))
28749  if (i1==i) then
28750  a = 1.
28751  else
28752  rdr2 = rsq/dr**2
28753  sqr = sqrt(4.*rdr2-1.)
28754  rminsq = (halfdr*(sqr-1.))**2
28755  rmaxsq = (halfdr*(sqr+1.))**2
28756  if (i1<i) then
28757  a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
28758  else
28759  a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
28760  end if
28761  end if
28762  b = 1. - a
28763  cc = 1.
28764  if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
28765  d = 1. - cc
28766  k = (jm1-1)*nr + i
28767  aa(k) = aa(k) + a*cc
28768  k = k + i1 - i
28769  aa(k) = aa(k) + b*cc
28770  k = (j1-1)*nr + i
28771  aa(k) = aa(k) + a*d
28772  k = k + i1 - i
28773  aa(k) = aa(k) + b*d
28774  end if
28775 120 end do
28776  eng = float(ng)
28777  ! find ismax for each j
28778  do j = 1, nz
28779  l = (j-1)*nr
28780  k = nr
28781  do i = 1, nr
28782  m = l + k
28783  if (aa(m)<=0.00) then
28784  k = k - 1
28785  go to 130
28786  else
28787  go to 140
28788  end if
28789 130 continue
28790  end do
28791 140 ismax(j) = k
28792  end do
28793  ! find iemax for each j
28794  iemax(1) = 1 + ismax(1)
28795  do j = 2, nz
28796  iemax(j) = 1 + max0(ismax(j-1), ismax(j))
28797  end do
28798  iemax(nz1) = 1 + ismax(nz)
28799  ! set er and ez to zero
28800  do i = 1, im2
28801  er(i) = 0.0
28802  ez(i) = 0.0
28803  end do
28804  ! sum up fields
28805  do js = 1, nz
28806  js1 = js + 1
28807  ism = ismax(js)
28808  if (ism==0) go to 220
28809  do is = 1, ism
28810  l = (js-1)*nr + is
28811  a1 = aa(l)
28812  if (a1==0.) go to 210
28813  l = (is-1)*im3
28814  do je = 1, js
28815  k1 = l + (js-je)*nr1
28816  n1 = (je-1)*nr1
28817  iem = iemax(je)
28818  if (iem<=1) go to 180
28819  do ie = 1, iem
28820  n = n1 + ie
28821  k = k1 + ie
28822  er(n) = er(n) + a1*ers(k)
28823  ez(n) = ez(n) - a1*ezs(k)
28824  end do
28825 180 end do
28826  do je = js1, nz1
28827  k1 = l + (je-js1)*nr1
28828  n1 = (je-1)*nr1
28829  iem = iemax(je)
28830  if (iem<=1) go to 200
28831  do ie = 1, iem
28832  n = n1 + ie
28833  k = k1 + ie
28834  er(n) = er(n) + a1*ers(k)
28835  ez(n) = ez(n) + a1*ezs(k)
28836  end do
28837 200 end do
28838 210 end do
28839 220 end do
28840  ! evaluate and apply impulse
28841  rrmax = 0.
28842  zzmax = 0.
28843  zzmin = 1000.
28844  npz = 0
28845  npr = 0
28846  do np = 1, ngood
28847  ! Transforming to the bunch reference frame
28848 
28849  if (f(9,np)==cstat(isp)) then
28850  dwc = f(7, np) - xmat
28851  gm1 = dwc/xmat
28852  ! convert xp an yp from mrad to rad
28853  f3np = f(3, np)*1.e-03
28854  f5np = f(5, np)*1.e-03
28855  ! omment gm1*(2.+gm1)=(gam-1)*(gam+1)=gam*gam-1=beta*beta*gam*gam
28856  bgz = sqrt(gm1*(2.+gm1))
28857  bgx = bgz*f3np
28858  bgy = bgz*f5np
28859  gamma = 1. + gm1
28860  ! Particle momentum in the bunch frame
28861 
28862  bgzstar = gam*(bgz-beta*gamma)
28863 
28864  ! Particle energy in bunch frame
28865 
28866  gstar = gam*(gamma-beta*bgz)
28867 
28868  r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
28869  if (r>=rrmax) rrmax = r
28870  if (r==0.) r = .000001
28871  xor = (f(2,np)-xbar)*xfac/r
28872  yor = (f(4,np)-ybar)*yfac/r
28873  if (r>rmax) then
28874  npr = npr + 1
28875  go to 230
28876  end if
28877  zph = f(6, np)*fh
28878  z = -c2*(zph-phimc)
28879  if (z>=zzmax) zzmax = z
28880  if (z<zzmin) zzmin = z
28881  if (abs(z)>hl) then
28882  npz = npz + 1
28883  go to 230
28884  end if
28885  ! interpolate impulse within mesh.
28886  rb = r/dr
28887  i = idint(1.+rb)
28888  a = rb - float(i-1)
28889  b = 1. - a
28890  zb = (z+hl)/dz
28891  j = idint(1.+zb)
28892  c = zb - float(j-1)
28893  d = 1. - c
28894  l = i + (j-1)*nr1
28895  m = l + nr1
28896  cbgr = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
28897  cbgzs = c3*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
28898  cbgr = cbgr*abs(f(9,np))
28899  cbgzs = cbgzs*abs(f(9,np))
28900  go to 260
28901  ! estimate impulse based on point charge at xbar,ybar,pbar.
28902  ! estimate impulse based on point charge at xbar,ybar,pbar.
28903 230 continue
28904  d = sqrt(z**2+r**2)
28905  rod3 = r/d**3
28906  zod3 = z/d**3
28907  if (nip==0) go to 250
28908  ! include neighboring bunches.
28909  do i = 1, nip
28910  xi = i
28911  do j = 1, 2
28912  s = z + xi*pl
28913  d = sqrt(s**2+r**2)
28914  rod3 = rod3 + r/d**3
28915  zod3 = zod3 + s/d**3
28916  xi = -xi
28917  end do
28918  end do
28919  ! Evaluate impulse.
28920 
28921 250 cbgr = eng*c1*c3*rod3*pi/2.
28922  cbgzs = eng*c1*c3*zod3*pi/2.
28923  cbgr = cbgr*abs(f(9,np))
28924  cbgzs = cbgzs*abs(f(9,np))
28925 
28926  ! Apply impulse and transform back to lab frame.
28927 
28928 260 bgx = bgx + cbgr*xor
28929  bgy = bgy + cbgr*yor
28930  bgzstar = bgzstar + cbgzs
28931  gstar = 1. + 0.5*bgzstar**2
28932  bgzf = gam*(bgzstar+beta*gstar)
28933  f3 = bgx/bgzf
28934  f5 = bgy/bgzf
28935  dww = f(7, np) - xmat
28936  dws = dww*((gamma+1.)/gamma)*(bgzf-bgz)/bgz
28937  ! ********************
28938  if (.not. iesp) then
28939  ! load the entrance beam parameters for cavities or gaps
28940  do js = 1, 7
28941  f(js, np) = fs(js, np)
28942  end do
28943  ! dxp and dyp are the jumps of xp and yp (in rad) at the position dz1*xpsc (in m)
28944  dxp = f3 - f3np
28945  dyp = f5 - f5np
28946  ! correction of xp and yp ( in rad)
28947  f(3, np) = f(3, np) + dxp*1000.
28948  f(5, np) = f(5, np) + dyp*1000.
28949  f(2, np) = f(2, np) - dz1*100.*dxp*xpsc
28950  f(4, np) = f(4, np) - dz1*100.*dyp*xpsc
28951  dwp(np) = dws
28952  else
28953  f(3, np) = f3*1000.
28954  f(5, np) = f5*1000.
28955  f(7, np) = f(7, np) + dws
28956  end if
28957  end if
28958  end do
28959  ! big enddo of isp
28960  end do
28961  return
28962  end subroutine scheff_sep
28963  ! *******************************************************************
28964  ! SUBROUTINE rfkick(v,dp,harm,nvf)
28965  ! RFKICK (NO SPACE CHARGE EFFECT)
28966 
28967  ! Contributing Author: Daniel Alt, NSCL/MSU, East Lansing, MI, USA
28968  ! Date: 23-May-2014
28969 
28970  ! Electric RF kicker. Simulates a sine wave chopper consisting
28971  ! of two plates deflecting the beam in the transverse direction.
28972  ! This is a zero length element.
28973 
28974  ! V: Voltage Factor. Consists of plate voltage in kV, times
28975  ! the electrode length divided by the gap between them.
28976  ! DP: RF phase offset in radians
28977  ! Harm: Kicker harmonic number relative to current reference
28978  ! frequency
28979  ! NVF: Kicker axis: 0 = horziontal, 1= vertical (use negative
28980  ! voltage for negative deflection)
28981  ! *******************************************************************
28982  subroutine rfkick(v, dp, harm, nvf)
28983  implicit real *8(a-h, o-z)
28984  parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
28985  common /rigid/boro
28986  common /consta/vl, pi, xmat, rpel, qst
28987  common /dyn/tref, vref
28988  common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
28989  common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
28990  common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
28991  common /faisc/f(10, iptsz), imax, ngood
28992  common /etcom/cog(8), exten(17), fd(iptsz)
28993  common /fene/wdisp, wphas, wx, wy, rlim, ifw
28994  common /corec/tref1
28995  common /qmoyen/qmoy
28996  common /aerp/vphase, vfield, ierpf
28997  common /itvole/itvol, imamin
28998  common /compt/nrres, nrtre, nrbunc, nrdbun
28999  common /shif/dtiph, shift
29000  common /tofev/ttvols
29001  character *1 cr
29002  ! dimension vecx(1)
29003  logical chasit, itvol, imamin, shift
29004  ! ENVELOPE
29005  call stapl(davtot*10.)
29006  ! xx ilost=0
29007  twopi = 2.*pi
29008  freq = fh/twopi
29009  wavel = vl/freq
29010  fcpi = fh*180./pi
29011  ! print out on terminal of transport element # on one and the same line
29012  cr = char(13)
29013  write (6, 8254) nrtre, cr
29014 8254 format ('Transport element:', i5, a1, $)
29015  if (harm<=0.) harm = 1.
29016  ! test window - unneccesary at START of element - Alt
29017  ! call reject(ilost)
29018  ! Calculate tof, beta, gamma, k.e. for c.o.g.
29019  tcog = 0.
29020  bcog = 0.
29021  do np = 1, ngood
29022  tcog = tcog + f(6, np)
29023  gpa = f(7, np)/xmat
29024  bcog = sqrt(1.-1./(gpa*gpa)) + bcog
29025  end do
29026  tcog = tcog/float(ngood)
29027  bcog = bcog/float(ngood)
29028  gcog = 1./sqrt(1.-bcog*bcog)
29029  encog = xmat*gcog - xmat
29030  ! adjustement of the phase of RF w.r.t. the T.O.F.
29031  xkpi = 0.
29032  if (imamin) then
29033  ttvpi = harm*ttvols*fcpi
29034  xkpi = ttvpi/360.
29035  ixkpi = int(xkpi)
29036  xkpi = (xkpi-float(ixkpi))*360.
29037  write (16, *) ' *** TOF correction:', -xkpi, ' deg'
29038  dp = dp - xkpi*pi/180.
29039  write (16, *) ' ***phase of RF adjusted : ', dp*180./pi, ' deg'
29040  end if
29041  ! start of write to file '.short' for kicker
29042  idav = idav + 1
29043  iitem(idav) = 22
29044  dav1(idav, 1) = v
29045  dav1(idav, 2) = dp*180./pi
29046  dav1(idav, 3) = nvf
29047  dav1(idav, 4) = davtot*10.
29048  ! if(itvol) dav1(idav,5)=-xkpi
29049  dav1(idav, 5) = harm
29050  ! end
29051  write (16, 178)
29052 178 format (/, ' Longitudinal parameters', /, 5x, ' BETA GAMMA ENERGY(MeV) ', &
29053  ' TOF(deg) TOF(sec)')
29054  write (16, 1788) bcog, gcog, encog, tcog*fcpi, tcog
29055 1788 format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
29056  e0t = harm*v/(bcog*wavel)
29057  cay = harm*twopi/(bcog*gcog*wavel)
29058  caysq = cay**2
29059  con = twopi*e0t*qmoy/xmat
29060  rad = pi/180.
29061  ! shift=true => reference and COG seperated, otherwise reference=COG
29062  ! --- save the reference
29063  ovref = vref
29064  otref = tref
29065  ! --- shift = false: the reference particle is the cog
29066  if (shift) then
29067  ovref = vref
29068  beref = vref/vl
29069  gamref = 1./sqrt(1.-beref*beref)
29070  older = xmat*gamref
29071  else
29072  tref = tcog
29073  vref = bcog*vl
29074  ovref = vref
29075  beref = bcog
29076  gamref = 1./sqrt(1.-beref*beref)
29077  older = xmat*gamref
29078  end if
29079  ! --- if imamin = false: phase setting has been forced equal to dp, otherwise phase setting has been adjusted
29080  enrprin = older - xmat
29081  write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
29082 165 format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
29083  wsync = 0.
29084  bcour = 0.
29085  tcog = 0.
29086  do np = 1, ngood
29087  a = harm*(f(6,np)-tref+ttvols)*fh + dp
29088  s = sin(a)
29089  w = f(7, np) - xmat
29090  gpai = f(7, np)/xmat
29091  bg = sqrt(w/xmat*(2.+w/xmat))
29092  bpai = bg/gpai
29093  const = (gpai/(gpai*gpai-1.))*f(9, np)
29094  disp = const*v/xmat*s
29095  bcour = bcour + bpai
29096  tcog = tcog + f(6, np)
29097  if (nvf==0) then
29098  f(3, np) = f(3, np) + disp
29099  else if (nvf==1) then
29100  f(5, np) = f(5, np) + disp
29101  else
29102  write (6, *) 'Invalid parameter NVF in RFKICK'
29103  end if
29104  wsync = wsync + w
29105  end do
29106  wsync = wsync/float(ngood)
29107  bcour = bcour/float(ngood)
29108  tcog = tcog/float(ngood)
29109  ! Test window
29110  call reject(ilost)
29111  ! dave start for kicker
29112  dav1(idav, 36) = ngood
29113  call emiprt(0)
29114  return
29115  end subroutine rfkick
29116 
function vppi(k)
Definition: dynac.F90:8583
function denrs(xyz)
Definition: dynac.F90:3354
subroutine chasel
Definition: dynac.F90:9908
function tsb0(betr)
Definition: dynac.F90:17308
subroutine schermi
Definition: dynac.F90:10782
subroutine zrotat(zrot)
Definition: dynac.F90:21917
subroutine scheff1_swesson(int)
Definition: dynac.F90:22475
subroutine xtypm(gami, saphi, qsc, dcg)
Definition: dynac.F90:2449
subroutine hersc(ini)
Definition: dynac.F90:9116
function varxy(xi, xf, ik)
Definition: dynac.F90:3438
function variz(bb, cc, dd, ee, ee1)
Definition: dynac.F90:3082
function snzd(cc, dd)
Definition: dynac.F90:2803
subroutine fposbb(xlcum)
Definition: dynac.F90:26089
subroutine trms(isucc)
Definition: dynac.F90:5272
function sgppp(it1, it2, it3)
Definition: dynac.F90:7866
subroutine table(lbmax, mbmax, nbmax)
Definition: dynac.F90:5062
function fcav(xc, nrc)
Definition: dynac.F90:16819
function epip(it1, it2, it3)
Definition: dynac.F90:6270
function denpd(xyz, nmaxy, nmaz)
Definition: dynac.F90:3187
subroutine area(init)
Definition: dynac.F90:18210
function eipp(it1, it2, it3)
Definition: dynac.F90:6420
subroutine sizrms(imaxd, xrms, yrms, zrms, zmin)
Definition: dynac.F90:2739
function sppp(it1, it2, it3)
Definition: dynac.F90:7599
function tta1(betr)
Definition: dynac.F90:16948
subroutine boucle(ipas, gamref, saphi, dcum, delphr)
Definition: dynac.F90:13429
subroutine disp
Definition: dynac.F90:21864
function tsb5(betr)
Definition: dynac.F90:17668
subroutine pintim
Definition: dynac.F90:10468
function epii(it1, it2, it3)
Definition: dynac.F90:6370
function vppp(k)
Definition: dynac.F90:8535
function slopf(n, xv)
Definition: dynac.F90:18181
function tta2(betr)
Definition: dynac.F90:17020
subroutine xtypl2(gami, saphi, qsc, dcg)
Definition: dynac.F90:1917
function varzr(ee, cc, nmazr)
Definition: dynac.F90:3461
subroutine matrix
Definition: dynac.F90:22102
subroutine xtypl1(gami, saphi, qsc, dcg)
Definition: dynac.F90:9646
function scgx(xi, xf)
Definition: dynac.F90:3368
subroutine rluxat(lout, inout, k1, k2)
Definition: dynac.F90:12053
subroutine rharm
Definition: dynac.F90:17735
function codsy(bb, cc, dd, ee, kap)
Definition: dynac.F90:2971
function spline(n, xv)
Definition: dynac.F90:18005
function sgiii(it1, it2, it3)
Definition: dynac.F90:8238
subroutine dwref(phi0, gam5, t5)
Definition: dynac.F90:25858
function prinz(cc, dd, kap, zrmss1)
Definition: dynac.F90:2852
program dynac
Definition: dynac.F90:49
subroutine sizcor(ect, xrms, yrms, zrms, imaxd)
Definition: dynac.F90:2691
function tsb4(betr)
Definition: dynac.F90:17596
subroutine fposb
Definition: dynac.F90:26148
function snzt(cc, dd)
Definition: dynac.F90:2782
subroutine adjrfq
Definition: dynac.F90:12215
function xj1(phi0, t0)
Definition: dynac.F90:26333
function copdr(xi, xf, kap)
Definition: dynac.F90:3295
subroutine fieldcav(atte)
Definition: dynac.F90:16652
function uppp(it1, it2, it3)
Definition: dynac.F90:8298
subroutine chasey
Definition: dynac.F90:10211
function ta1(betr, nrc)
Definition: dynac.F90:16925
subroutine benmag(sbet, fdtot)
Definition: dynac.F90:19452
function vpip(k)
Definition: dynac.F90:8559
subroutine refer
Definition: dynac.F90:14343
subroutine zrotap(zrot)
Definition: dynac.F90:21984
function sipp(it1, it2, it3)
Definition: dynac.F90:7332
subroutine fdrift(xl, npart, imit)
Definition: dynac.F90:21650
subroutine intfac(tofini)
Definition: dynac.F90:12333
function sgpip(it1, it2, it3)
Definition: dynac.F90:7919
subroutine mfordre(rc, ra, rb)
Definition: dynac.F90:21261
function sb1(betr, nrc)
Definition: dynac.F90:17357
function xitl3(gami, gams, betr, nit, saphi, qqc)
Definition: dynac.F90:1867
function sb4(betr, nrc)
Definition: dynac.F90:17573
subroutine sposb
Definition: dynac.F90:26208
subroutine accep_rfq(pib)
Definition: dynac.F90:23442
subroutine steer(fld, nvf)
Definition: dynac.F90:14466
subroutine deriv2(n)
Definition: dynac.F90:18053
function sgipi(it1, it2, it3)
Definition: dynac.F90:8185
function tta3(betr)
Definition: dynac.F90:17092
subroutine entre
Definition: dynac.F90:11194
subroutine cesp(xlqua)
Definition: dynac.F90:27699
subroutine schfdyn
Definition: dynac.F90:4722
subroutine syrout(ii)
Definition: dynac.F90:19870
function eiii(it1, it2, it3)
Definition: dynac.F90:6570
subroutine hcoef
Definition: dynac.F90:8836
subroutine intg3(npt)
Definition: dynac.F90:4752
subroutine tiltbm_bis(icg)
Definition: dynac.F90:15224
function eppi(it1, it2, it3)
Definition: dynac.F90:6320
subroutine eugwrt
Definition: dynac.F90:12596
function upip(it1, it2, it3)
Definition: dynac.F90:8328
function xi2(phi0, t0)
Definition: dynac.F90:26301
subroutine fldsol(dbs, step)
Definition: dynac.F90:20950
function varia(bb, cc, dd, ee)
Definition: dynac.F90:3045
function spip(it1, it2, it3)
Definition: dynac.F90:7664
function vipp(k)
Definition: dynac.F90:8631
subroutine sextu(imk2, arg, xlsex, rg)
Definition: dynac.F90:19950
subroutine ytzp
Definition: dynac.F90:15533
subroutine flds(r, z, er, ez)
Definition: dynac.F90:4158
function ta5(betr, nrc)
Definition: dynac.F90:17213
subroutine bcnum(phref, ylg, ncell)
Definition: dynac.F90:26482
subroutine solnoid(imks, arg, xlsol)
Definition: dynac.F90:21011
function sgpii(it1, it2, it3)
Definition: dynac.F90:8026
function ta4(betr, nrc)
Definition: dynac.F90:17141
subroutine compress(pib)
Definition: dynac.F90:4829
function codif(bb, cc, dd, ee, ee1, kap)
Definition: dynac.F90:3008
function xe21(phi0, t0)
Definition: dynac.F90:26400
subroutine elqsex
Definition: dynac.F90:20693
function xe22(phi0, t0)
Definition: dynac.F90:26440
subroutine prbeam(iflg, wfile)
Definition: dynac.F90:4879
subroutine syref
Definition: dynac.F90:19912
subroutine phcrest1(phi0, ylg, ncell)
Definition: dynac.F90:25729
function spii(it1, it2, it3)
Definition: dynac.F90:7794
function viii(k)
Definition: dynac.F90:8703
subroutine gap(gamref, saphi, gams, delphr)
Definition: dynac.F90:13132
function sppi(it1, it2, it3)
Definition: dynac.F90:7729
subroutine ext2(idch)
Definition: dynac.F90:3721
subroutine rchsom(zi, zf, nmaz)
Definition: dynac.F90:2878
subroutine schefini
Definition: dynac.F90:28016
subroutine celint
Definition: dynac.F90:16744
subroutine statis
Definition: dynac.F90:14951
function dendif(z, aa, bb, cc, dd)
Definition: dynac.F90:3168
subroutine xtylpk(gami, saphi, qsc, dcg)
Definition: dynac.F90:2211
subroutine intga(npt, ireca)
Definition: dynac.F90:2582
function eiip(it1, it2, it3)
Definition: dynac.F90:6470
function hermint(s, ihd)
Definition: dynac.F90:5172
function sgppi(it1, it2, it3)
Definition: dynac.F90:7973
subroutine daves
Definition: dynac.F90:18772
subroutine pintfast
Definition: dynac.F90:8727
function tppp(it1, it2, it3)
Definition: dynac.F90:6964
function eppp(it1, it2, it3)
Definition: dynac.F90:6221
subroutine pofar2(gap)
Definition: dynac.F90:19388
function tta4(betr)
Definition: dynac.F90:17164
subroutine phcrest(phi0, ylg, ncell, zcrest)
Definition: dynac.F90:25658
subroutine tiltz(tilta)
Definition: dynac.F90:4212
subroutine elsq
Definition: dynac.F90:21518
function ta0(betr, nrc)
Definition: dynac.F90:16852
subroutine solquad(iksq, args, argq, xlsol, rg)
Definition: dynac.F90:21294
function tpii(it1, it2, it3)
Definition: dynac.F90:7240
subroutine cpardyn(pib)
Definition: dynac.F90:22879
subroutine cogetc
Definition: dynac.F90:13381
subroutine elsex
Definition: dynac.F90:20630
function herm(m, x)
Definition: dynac.F90:2926
subroutine derif2(n)
Definition: dynac.F90:18093
subroutine randga(len, s, am, v)
Definition: dynac.F90:24762
function xitl0(gami, gams, betr, saphi, qqc)
Definition: dynac.F90:1767
function sipi(it1, it2, it3)
Definition: dynac.F90:7467
subroutine egun(fmult, indp)
Definition: dynac.F90:22135
function densy(m, y, ireca)
Definition: dynac.F90:3334
function fper(i, j)
Definition: dynac.F90:5149
subroutine rlux(rvec, lenv)
Definition: dynac.F90:11828
subroutine tdens(m, ireca, iacc)
Definition: dynac.F90:4678
function tsb3(betr)
Definition: dynac.F90:17524
subroutine aliner
Definition: dynac.F90:22032
function upii(it1, it2, it3)
Definition: dynac.F90:8388
subroutine etac
Definition: dynac.F90:3882
function sgiip(it1, it2, it3)
Definition: dynac.F90:8132
subroutine rotat(ii)
Definition: dynac.F90:21481
function vipi(k)
Definition: dynac.F90:8679
subroutine restay
Definition: dynac.F90:16102
subroutine drift(dl)
Definition: dynac.F90:21665
subroutine xtypj(gami, saphi, qsc, dcg)
Definition: dynac.F90:2319
function grz(aa, bb, cc, dd, ee)
Definition: dynac.F90:3118
function sb3(betr, nrc)
Definition: dynac.F90:17501
subroutine rfq_parm
Definition: dynac.F90:23563
subroutine chrefe
Definition: dynac.F90:3839
subroutine emit3d
Definition: dynac.F90:14869
subroutine schermi1
Definition: dynac.F90:10556
subroutine qelec(volt, xlqua, rs)
Definition: dynac.F90:24787
function fpar(i, j)
Definition: dynac.F90:5135
subroutine plprf1
Definition: dynac.F90:17807
function uiii(it1, it2, it3)
Definition: dynac.F90:8506
function tsb2(betr)
Definition: dynac.F90:17452
subroutine plprf2
Definition: dynac.F90:17892
subroutine rchsor(aa, bb, cc, dd, zs)
Definition: dynac.F90:2900
subroutine chase
Definition: dynac.F90:10187
function tpip(it1, it2, it3)
Definition: dynac.F90:7056
function xj2(phi0, t0)
Definition: dynac.F90:26367
subroutine accept
Definition: dynac.F90:15408
function corxy(xi, xf, kap, ik, xyrms)
Definition: dynac.F90:3414
subroutine stripp
Definition: dynac.F90:24524
function xitl2(gami, gams, betr, saphi, qqc)
Definition: dynac.F90:1824
subroutine gausse
Definition: dynac.F90:5010
function drxyz(m, xyz, ireca)
Definition: dynac.F90:3201
subroutine bunparm(v, dp, harm, prlim)
Definition: dynac.F90:14108
subroutine qasex(iksq, args, argq, xlqua, rg)
Definition: dynac.F90:20347
function bint(n, z)
Definition: dynac.F90:23416
subroutine rluxin(isdext)
Definition: dynac.F90:11944
subroutine sizer(ist, xrms, yrms, zrms)
Definition: dynac.F90:27752
subroutine elqua
Definition: dynac.F90:20563
function slope(n, xv)
Definition: dynac.F90:17979
subroutine e_deflec
Definition: dynac.F90:27427
subroutine crest(betr, eqvl, xpos, bkcr, ffield)
Definition: dynac.F90:4028
function dendir(z, aa, bb, cc, dd, ee)
Definition: dynac.F90:3144
function tppi(it1, it2, it3)
Definition: dynac.F90:7148
subroutine qalva(bquad, xlqua, rg)
Definition: dynac.F90:20143
subroutine histgrm
Definition: dynac.F90:18353
function splinf(n, xv)
Definition: dynac.F90:18133
function tsb1(betr)
Definition: dynac.F90:17380
function tiip(it1, it2, it3)
Definition: dynac.F90:6707
subroutine rfq_o3
Definition: dynac.F90:4266
subroutine gaus(r1, r2, z1, z2, opt, er, ez)
Definition: dynac.F90:4098
subroutine bhdist
Definition: dynac.F90:5239
function siip(it1, it2, it3)
Definition: dynac.F90:7401
subroutine randali
Definition: dynac.F90:22056
subroutine eint(a, ee, ek)
Definition: dynac.F90:4198
function tipp(it1, it2, it3)
Definition: dynac.F90:6621
subroutine pofar1(gap)
Definition: dynac.F90:19322
function hers(m, x)
Definition: dynac.F90:3268
subroutine rluxgo(lux, ins, k1, k2)
Definition: dynac.F90:12080
function sb0(betr, nrc)
Definition: dynac.F90:17285
subroutine etgap
Definition: dynac.F90:12636
subroutine cavnum
Definition: dynac.F90:25257
subroutine aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
Definition: dynac.F90:26856
function tiii(it1, it2, it3)
Definition: dynac.F90:6878
subroutine rmami
Definition: dynac.F90:1643
subroutine rluxut(isdext)
Definition: dynac.F90:12012
function gamci(phi, pcresi, gami, ist, qsc)
Definition: dynac.F90:2552
function uiip(it1, it2, it3)
Definition: dynac.F90:8447
subroutine chasex
Definition: dynac.F90:10046
function uppi(it1, it2, it3)
Definition: dynac.F90:8358
function siii(it1, it2, it3)
Definition: dynac.F90:7533
subroutine cobeam(ii, xl)
Definition: dynac.F90:21807
subroutine gcern(len, s, am, v)
Definition: dynac.F90:12197
function sb5(betr, nrc)
Definition: dynac.F90:17645
function viip(k)
Definition: dynac.F90:8655
subroutine mytime(iitime)
Definition: dynac.F90:1616
subroutine clear
Definition: dynac.F90:21778
subroutine ext2d(idch)
Definition: dynac.F90:3578
subroutine reject(ilost)
Definition: dynac.F90:26691
subroutine uvrms
Definition: dynac.F90:5347
subroutine itrd3
Definition: dynac.F90:25968
subroutine qfk(ityqu, arg, xlqua, rs)
Definition: dynac.F90:24992
function factd(m)
Definition: dynac.F90:5212
subroutine monte
Definition: dynac.F90:11371
subroutine profil
Definition: dynac.F90:17788
function xi1(phi0, t0, t5)
Definition: dynac.F90:26268
function fact(m)
Definition: dynac.F90:5198
subroutine scheff_sep
Definition: dynac.F90:28559
function vpii(k)
Definition: dynac.F90:8607
subroutine rfkick(v, dp, harm, nvf)
Definition: dynac.F90:28983
function densz(m, z, ireca)
Definition: dynac.F90:2952
subroutine pintim1(ist)
Definition: dynac.F90:27796
subroutine cdg(idch)
Definition: dynac.F90:3500
function ta3(betr, nrc)
Definition: dynac.F90:17069
function densx(m, x, ireca)
Definition: dynac.F90:3315
subroutine xtyplp1(gami, saphi, qsc, dcg)
Definition: dynac.F90:2081
function tta0(betr)
Definition: dynac.F90:16876
subroutine elsol
Definition: dynac.F90:21189
function tta5(betr)
Definition: dynac.F90:17236
function ta2(betr, nrc)
Definition: dynac.F90:16997
subroutine fposbbb(xlcum, fposs, jx)
Definition: dynac.F90:26014
function sb2(betr, nrc)
Definition: dynac.F90:17429
function fone(z)
Definition: dynac.F90:17718
subroutine scheff1(idum)
Definition: dynac.F90:28099
function sgipp(it1, it2, it3)
Definition: dynac.F90:8079
function vaprz(cc, dd)
Definition: dynac.F90:2826
function eipi(it1, it2, it3)
Definition: dynac.F90:6520
function uipi(it1, it2, it3)
Definition: dynac.F90:8476
subroutine stapl(zpos)
Definition: dynac.F90:12492
subroutine grcomp(text, iskale)
Definition: dynac.F90:15888
function scgy(xi, xf)
Definition: dynac.F90:3391
subroutine rgaus2(sigma, y1, y2, y3, y4)
Definition: dynac.F90:11751
subroutine emiprt(l)
Definition: dynac.F90:14563
subroutine fielde(lc, mc, nc, isucc)
Definition: dynac.F90:5452
function uipp(it1, it2, it3)
Definition: dynac.F90:8418
function tipi(it1, it2, it3)
Definition: dynac.F90:6792
subroutine deflect(fdtot)
Definition: dynac.F90:27308
subroutine b_sep(isepa)
Definition: dynac.F90:27894
subroutine solfield(bcret, intgr)
Definition: dynac.F90:20794
subroutine tiltbm(icg)
Definition: dynac.F90:15044
subroutine corre(n, nall)
Definition: dynac.F90:10350
subroutine shuffle
Definition: dynac.F90:1707